Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func.
Require Import Functor.Functor_Extender.
Require Import NatTrans.NatTrans NatTrans.Operations
        NatTrans.Func_Cat NatTrans.NatIso.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations
        Ext_Cons.Prod_Cat.Nat_Facts.
Require Import Adjunction.Adjunction.
Require Import KanExt.Local.
Require Import Basic_Cons.Terminal.

Local Open Scope functor_scope.

(** This module contains conversion from local kan extensions defined through
    hom functor to local kan extensions defined through cones. *)
Section Hom_Local_Right_KanExt_to_Local_Right_KanExt.
  Context {C C' : Category} {p : C –≻ C'}
          {D : Category} {F : C –≻ D}
          (hlrke : Hom_Local_Right_KanExt p F).

  (** The cone that is the kan extension. *)
  Definition Hom_Local_Right_KanExt_to_Local_Right_KanExt_Terminal_Cone :
    LoKan_Cone p F :=
    {|
      cone_apex := hlrke;
      cone_edge :=
        Trans (inverse_morphism (HLRKE_Iso hlrke)) hlrke (NatTrans_id hlrke)
    |}.

  (** The cone we just constructed is (as we will prove) the local kan
      extension and thus the terminal cone. So we abbreviate it as TCONE. *)
  Local Notation TCONE :=
    Hom_Local_Right_KanExt_to_Local_Right_KanExt_Terminal_Cone (only parsing).

  (** Given a cone Cn, we construct a cone morph from Cn to the cone that is the
local kan extension. *)
  Section Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone.
    Context (Cn : LoKan_Cone p F).

    Program Definition
            Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone :
      LoKan_Cone_Morph Cn TCONE :=
      {|
        cone_morph := Trans (iso_morphism (HLRKE_Iso hlrke)) Cn Cn
      |}.

    Next Obligation.
    Proof.
      set (W :=
             f_equal (
                 fun w :
                       (((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func _))
                             ∘ (Left_Functor_Extender p D)^op)
                         –≻ ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ F (Hom_Func _))
                            ∘ (Left_Functor_Extender p D)^op
                         ))%nattrans =>
                   Trans w Cn
               ) (left_inverse (HLRKE_Iso hlrke))).
      cbn in W.
      match goal with
        [|- ?A = ?B] =>
        match type of W with
          ?X = _ =>
          cut (X A = X B);
            [rewrite (equal_f W A); rewrite (equal_f W B); trivial|clear W]
        end
      end.
      apply f_equal.
      set (M :=
             equal_f
               (@Trans_com _ _ _ _
                           (iso_morphism (HLRKE_Iso hlrke))
                           hlrke
                           Cn
                           (Trans (iso_morphism (HLRKE_Iso hlrke)) Cn Cn)
               )
               (Trans (inverse_morphism (HLRKE_Iso hlrke))
                      hlrke (NatTrans_id hlrke))).
      cbn in M.
      repeat rewrite NatTrans_id_unit_left in M.
      rewrite M; clear M.
      apply NatTrans_eq_simplify; extensionality x; cbn.
      cbn_rewrite (
          f_equal
            (fun w :
                   ((@Fix_Bi_Func_2 _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                      –≻ (@Fix_Bi_Func_2 _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                   )%nattrans
             => Trans w hlrke (NatTrans_id _)
            )
            (right_inverse (HLRKE_Iso hlrke))
        ).
      cbn; auto.
    Qed.

  End Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone.

  (** We show that any two cone morphs to TCONE (see above) are equal. *)
  Section
    Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique.
    Context {Cn : LoKan_Cone p F} (h h' : LoKan_Cone_Morph Cn TCONE).

    Theorem
      Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique
      : h = h' :> (_ –≻ _)%nattrans.
    Proof.
      set (Mh :=
             equal_f
               (@Trans_com _ _ _ _ (iso_morphism (HLRKE_Iso hlrke)) hlrke Cn h)
               (Trans (inverse_morphism (HLRKE_Iso hlrke))
                      hlrke (NatTrans_id hlrke))
          ).
      set (Mh' :=
             equal_f
               (@Trans_com _ _ _ _ (iso_morphism (HLRKE_Iso hlrke)) hlrke Cn h')
               (Trans (inverse_morphism
                         (HLRKE_Iso hlrke)) hlrke (NatTrans_id hlrke))
          ).
      cbn in Mh, Mh'.
      cbn_rewrite ((f_equal
                      (fun w :
                           ((@Fix_Bi_Func_2
                               _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                              –≻ (@Fix_Bi_Func_2
                                    _ (Func_Cat _ _) _ hlrke (Hom_Func _))
                           )%nattrans
                       => Trans w hlrke (NatTrans_id _))
                      (right_inverse (HLRKE_Iso hlrke)))) in Mh Mh'.
      repeat rewrite NatTrans_id_unit_left in Mh, Mh'.
      destruct Mh; destruct Mh'.
      apply f_equal.
      etransitivity;
        [symmetry; apply (cone_morph_com h) | apply (cone_morph_com h')].
    Qed.

  End
    Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique.

  (** Conversion from Hom_Local_Right_KanExt to Local_Right_KanExt. *)
  Definition Hom_Local_Right_KanExt_to_Local_Right_KanExt :
    Local_Right_KanExt p F :=
    {|
      LRKE := TCONE;
      LRKE_morph_ex :=
        Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone;
      LRKE_morph_unique :=
        @Hom_Local_Right_KanExt_to_Local_Right_KanExt_Morph_to_Terminal_Cone_unique
    |}.

End Hom_Local_Right_KanExt_to_Local_Right_KanExt.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************

          Buchberger : reduction  star

          Laurent Thery May 97 (revised April 01)

  ****************************************************************************)
Require Export Preduceplus.
Unset Standard Proposition Elimination Names.
Section Preducestar.
Load "hCoefStructure".
Load "hOrderStructure".
Load "hReduceplus".

Inductive reducestar (Q : list (poly A0 eqA ltM)) :
list (Term A n) -> list (Term A n) -> Prop :=
    reducestar0 :
      forall p q : list (Term A n),
      reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p
        q ->
      irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
        q -> reducestar Q p q.

Theorem reducestar_eqp_com :
 forall (Q : list (poly A0 eqA ltM)) (p q r s : list (Term A n)),
 reducestar Q p q ->
 canonical A0 eqA ltM p ->
 eqP A eqA n p r -> eqP A eqA n q s -> reducestar Q r s.
intros Q p q r s H' H'0 H'1 H'2; inversion H'.
apply reducestar0; auto.
apply reduceplus_eqp_com with (p := p) (q := q) (1 := cs); auto.
apply irreducible_eqp_com with (p := q) (1 := cs); auto.
apply canonical_reduceplus with (1 := cs) (3 := H); auto.
Qed.

Definition mks :
  forall p : list (Term A n), canonical A0 eqA ltM p -> poly A0 eqA ltM.
intros p H'; exists p; exact H'.
Defined.

Definition selectdivf :
  forall a : Term A n,
  ~ zeroP (A:=A) A0 eqA (n:=n) a ->
  forall Q : list (poly A0 eqA ltM),
  {q : list (Term A n) |
  exists b : Term A n,
    (exists p : list (Term A n),
       divP A A0 eqA multA divA n a b /\
       inPolySet A A0 eqA n ltM q Q /\ q = pX b p)} +
  {(forall (b : Term A n) (q : list (Term A n)),
    inPolySet A A0 eqA n ltM (pX b q) Q -> ~ divP A A0 eqA multA divA n a b)}.
intros a Z Q; elim Q; auto.
right.
intros b q H'; inversion_clear H'.
intros a0; case a0.
intros x; case x.
intros c l H'; case H'.
intros H'1; case H'1.
intros x0 H'0; left.
exists x0.
elim H'0; intros b E; elim E; intros p E0; elim E0; intros H'2 H'3; elim H'3;
 intros H'4 H'5; try exact H'5; clear H'3 E0 E H'0.
exists b; exists p; split; [ idtac | split ]; auto.
apply inskip; auto.
intros H'0; right.
intros b q H'1; inversion_clear H'1; auto.
apply H'0 with (q := q); auto.
intros a1 l c l0 H'; case (divP_dec _ _ _ _ _ _ _ _ _ cs n a a1); auto.
apply canonical_nzeroP with (p := l) (ltM := ltM); auto.
intros divP1; left; exists (pX a1 l); auto.
exists a1; exists l; split; [ idtac | split ]; auto.
change
  (inPolySet A A0 eqA n ltM (pX a1 l)
     (exist (canonical A0 eqA ltM) (pX a1 l) c :: l0))
 in |- *.
apply incons with (a := a1) (p := l) (H := c); auto.
intros divP1; case H'; intros Hyp1.
case Hyp1.
intros x0 H'0; left; exists x0.
elim H'0; intros b E; elim E; intros p E0; elim E0; intros H'1 H'2; elim H'2;
 intros H'3 H'4; try exact H'4; clear H'2 E0 E H'0.
exists b; exists p; split; [ idtac | split ]; auto.
apply inskip; auto.
right.
intros b q H'1; generalize divP1; inversion_clear H'1; eauto.
Qed.

Definition selectpolyf :
  forall (Q : list (poly A0 eqA ltM)) (r : list (Term A n)),
  canonical A0 eqA ltM r ->
  {q : list (Term A n) |
  reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q r q} +
  {irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q r}.
intros Q r; elim r.
intros H'; right;
 change
   (irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
      (pO A n)) in |- *; apply pO_irreducible; auto.
intros a l H' H'0.
cut (canonical A0 eqA ltM l);
 [ intros C0 | apply canonical_imp_canonical with (a := a); auto ].
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros Z0 | apply canonical_nzeroP with (p := l) (ltM := ltM); auto ].
case (selectdivf a Z0 Q); intros Hyp1.
case Hyp1.
intros x0; case x0; left.
absurd True; auto.
elim e; intros b E; elim E; intros p E0; elim E0; intros H'1 H'2; elim H'2;
 intros H'3 H'4; inversion H'4; clear H'2 E0 E e.
cut (~ zeroP (A:=A) A0 eqA (n:=n) t); [ intros nZt | idtac ].
exists
 (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a t nZt l
    l0).
elim e; intros b E; elim E; intros p E0; elim E0; intros H'1 H'2; elim H'2;
 intros H'3 H'4; clear H'2 E0 E e.
change
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
     (pX a l)
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a t
        nZt l l0)) in |- *.
apply reducetop_sp with (1 := cs); auto.
rewrite (pX_invl A n t b l0 p); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l0).
apply inPolySet_imp_canonical with (L := Q); auto.
elim e; intros b E; elim E; intros p E0; elim E0; intros H'1 H'2; elim H'2;
 intros H'3 H'4; try exact H'3; clear H'2 E0 E e.
lapply H'; [ intros H'1; case H'1; clear H' | clear H' ].
intros H'; case H'.
intros x H'2; left; exists (pX a x).
change
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
     (pX a l) (pX a x)) in |- *.
apply reduceskip; auto.
intros H'; right;
 change
   (forall q : list (Term A n),
    ~
    reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
      (pX a l) q) in |- *.
intros q; red in |- *; intros H'2; generalize H' Hyp1; inversion_clear H'2.
intros H'3 H'4; lapply (H'4 b q0); [ intros H'7; apply H'7 | idtac ]; auto.
intros H'3 H'4;
 absurd
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q l q0);
 auto.
auto.
Qed.

Definition Reducef :
  forall (Q : list (poly A0 eqA ltM)) (p : poly A0 eqA ltM),
  {q : poly A0 eqA ltM |
  reducestar Q (s2p A A0 eqA n ltM p) (s2p A A0 eqA n ltM q)}.
intros Q p; pattern p in |- *.
apply well_founded_induction with (1 := sltp_wf _ A0 eqA _ ltM os).
intros x; case x.
intros x0; case x0.
intros o H'; simpl in |- *.
exists (mks (pO A n) (canonicalpO A A0 eqA n ltM)); simpl in |- *; auto.
apply reducestar0; auto.
apply Rstar_0; auto.
apply pO_irreducible; auto.
simpl in |- *; intros a l o H'; auto.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a);
 [ intros Z0 | apply canonical_nzeroP with (ltM := ltM) (p := l) ];
 auto.
lapply (selectdivf a);
 [ intros H'1; case (H'1 Q) | idtac ];
 auto; intros Div1.
case Div1.
intros x1; case x1.
intros H'0; absurd True; auto.
elim H'0; intros b E; elim E; intros p0 E0; elim E0; intros H'3 H'4; elim H'4;
 intros H'5 H'6; inversion_clear H'6; clear H'4 E0 E H'0.
intros a0 l0 H'0.
cut (~ zeroP (A:=A) A0 eqA (n:=n) a0); [ intros nZt | idtac ].
2: apply canonical_nzeroP with (p := l0) (ltM := ltM).
2: apply inPolySet_imp_canonical with (L := Q); auto.
2: elim H'0; intros b E; elim E; intros p0 E0; elim E0; intros H'3 H'4;
    elim H'4; intros H'5 H'6; try exact H'5; clear H'4 E0 E H'0.
cut
 (canonical A0 eqA ltM
    (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a a0
       nZt l l0)); [ intros Op2 | idtac ]; auto.
lapply
 (H'
    (mks
       (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
          a0 nZt l l0) Op2)); [ intros H'4; case H'4 | idtac ];
 auto.
intros x2 H'3; exists x2.
apply reducestar0; auto.
apply
 Rstar_n
  with
    (y := spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a
            a0 nZt l l0); auto.
elim H'0; intros b E; elim E; intros p0 E0; elim E0; intros H'5 H'6; elim H'6;
 intros H'7 H'8; clear H'6 E0 E H'0.
change
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
     (pX a l)
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a a0
        nZt l l0)) in |- *.
apply reducetop_sp with (1 := cs); auto.
rewrite (pX_invl A n a0 b l0 p0); auto.
inversion_clear H'3; auto.
inversion_clear H'3; auto.
simpl in |- *;
 apply
  ltP_reduce
   with (Q := Q) (eqA_dec := eqA_dec) (ltM_dec := ltM_dec) (1 := cs);
 auto.
elim H'0; intros b E; elim E; intros p0 E0; elim E0; intros H'3 H'4; elim H'4;
 intros H'5 H'6; clear H'4 E0 E H'0.
change
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
     (pX a l)
     (spminusf A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec a a0
        nZt l l0)) in |- *.
apply reducetop_sp with (1 := cs); auto.
rewrite (pX_invl A n a0 b l0 p0); auto.
apply canonical_spminusf with (1 := cs); auto.
apply canonical_imp_canonical with (a := a); auto.
elim H'0; intros b E; elim E; intros p0 E0; elim E0; intros H'3 H'4; elim H'4;
 intros H'5 H'6; clear H'4 E0 E H'0.
apply canonical_imp_canonical with (a := a0); auto.
apply inPolySet_imp_canonical with (L := Q); auto.
elim H'0; intros b E; elim E; intros p0 E0; elim E0; intros H'3 H'4; elim H'4;
 intros H'5 H'6; clear H'4 E0 E H'0.
rewrite (pX_invl A n a0 b l0 p0); auto.
cut (canonical A0 eqA ltM l);
 [ intros Op2 | apply canonical_imp_canonical with (a := a); auto ].
lapply (H' (mks l Op2)); simpl in |- *; [ intros H'3; case H'3 | idtac ];
 auto.
2: change (ltP (A:=A) (n:=n) ltM l (pX a l)) in |- *;
    apply ltP_refl_pX with (1 := cs); auto.
intros x1; case x1.
intros x2 c H'4; simpl in |- *; cut (canonical A0 eqA ltM (pX a x2));
 [ intros Op3 | auto ].
exists (mks (pX a x2) Op3); simpl in |- *.
apply reducestar0; auto.
change
  (reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
     (pX a l) (pX a x2)) in |- *.
apply reduceplus_skip with (1 := cs); auto.
inversion_clear H'4; auto.
change
  (forall p : list (Term A n),
   ~
   reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
     (pX a x2) p) in |- *.
intros p0; red in |- *; intros H'5; generalize H'4 Div1; inversion_clear H'5;
 simpl in |- *.
intros H'6 H'7; lapply (H'7 b q); [ intros H'10; apply H'10 | idtac ]; auto.
intros H'6 H'7;
 absurd
  (reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q x2 q);
 auto.
inversion_clear H'6; auto.
cut
 (reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
    (pX a l) (pX a x2)); [ intros Re0 | idtac ].
apply canonical_reduceplus with (1 := cs) (3 := Re0); auto.
apply reduceplus_skip with (1 := cs); auto.
inversion_clear H'4; auto.
Defined.

Theorem reduce0_reducestar :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 canonical A0 eqA ltM p -> exists t : list (Term A n), reducestar Q p t.
intros Q p H.
generalize (Reducef Q (mks p H)).
intros H'; elim H'.
simpl in |- *.
intros x H'0; exists (s2p A A0 eqA n ltM x); try assumption.
Qed.

Theorem reducestar_trans :
 forall (Q : list (poly A0 eqA ltM)) (x y z : list (Term A n)),
 canonical A0 eqA ltM x ->
 reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q x y ->
 reducestar Q y z -> reducestar Q x z.
intros Q x y z H' H'0 H'1; inversion H'1.
apply reducestar0; auto.
apply reduceplus_trans with (1 := cs) (y := y); auto.
Qed.

Theorem reducestar_reduceplus :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reducestar Q p q ->
 reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p q.
intros Q p q H'; inversion H'; auto.
Qed.

Theorem reducestar_irreducible :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reducestar Q p q ->
 irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q q.
intros Q p q H'; inversion H'; auto.
Qed.
Hint Resolve reducestar_reduceplus.

Theorem reducestar_inv :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 reducestar Q p q ->
 canonical A0 eqA ltM p ->
 eqP A eqA n p q /\
 irreducible A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p \/
 (exists r : list (Term A n),
    reduce A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q p r /\
    reducestar Q r q).
intros Q p q H'; elim H'.
intros p0 q0 H'0; inversion H'0.
intros H'1 H'2; left; split; auto.
apply irreducible_eqp_com with (1 := cs) (p := q0); auto.
apply eqp_imp_canonical with (p := p0) (1 := cs); auto.
apply (eqp_sym _ _ _ _ _ _ _ _ _ cs n); auto.
intros H'1 H'2; right; exists y; split; auto.
apply reducestar0; auto.
Qed.

Lemma pO_reducestar :
 forall (Q : list (poly A0 eqA ltM)) (p : list (Term A n)),
 reducestar Q (pO A n) p -> p = pO A n.
intros Q p H'.
cut
 (reduceplus A A0 A1 eqA invA minusA multA divA eqA_dec n ltM ltM_dec Q
    (pO A n) p); [ intros Red1 | apply reducestar_reduceplus; auto ].
apply pO_reduceplus with (2 := Red1); auto.
Qed.

Theorem reducestar_pO_is_pO :
 forall (Q : list (poly A0 eqA ltM)) (p q : list (Term A n)),
 canonical A0 eqA ltM p -> reducestar Q (pO A n) (pO A n).
intros Q p H' H'0; auto.
apply reducestar0; auto.
apply Rstar_0; auto.
apply pO_irreducible.
Qed.

Theorem reducestar_in_pO :
 forall (Q : list (poly A0 eqA ltM)) (a : Term A n) (p : list (Term A n)),
 inPolySet A A0 eqA n ltM p Q ->
 ~ zeroP (A:=A) A0 eqA (n:=n) a ->
 reducestar Q (mults (A:=A) multA (n:=n) a p) (pO A n).
intros Q a p H' H'0.
cut (canonical A0 eqA ltM p); [ intros Op0 | idtac ].
apply
 reducestar_eqp_com
  with
    (p := mults (A:=A) multA (n:=n) a p)
    (q := mults (A:=A) multA (n:=n) a (pO A n)); auto.
apply reducestar0; auto.
apply reduceplus_mults with (1 := cs); auto.
apply reduce_imp_reduceplus with (1 := cs); auto.
apply reduce_in_pO with (1 := cs); auto.
simpl in |- *; apply pO_irreducible; auto.
apply inPolySet_imp_canonical with (L := Q); auto.
Qed.

Definition pickinSet :
  forall a : Term A n,
  ~ zeroP (A:=A) A0 eqA (n:=n) a ->
  forall Q : list (poly A0 eqA ltM),
  {p : list (Term A n) | pickinSetp A A0 eqA multA divA n ltM a p Q} +
  {(forall (b : Term A n) (p q : list (Term A n)),
    inPolySet A A0 eqA n ltM p Q ->
    divP A A0 eqA multA divA n a b -> p <> pX b q)}.
intros a Z0 Q; elim Q.
right; intros b p q H'; inversion_clear H'.
intros a0; case a0.
intros x; case x.
intros c l H'; case H'; auto.
intros H'0; left; inversion_clear H'0.
exists x0; auto.
apply pickinSetskip; auto.
intros H'0; right.
intros b p q H'1; inversion_clear H'1.
intros H'3; red in |- *; intros H'4.
lapply (H'0 b p q);
 [ intros H'7; lapply H'7; [ intros H'8; clear H'7 | clear H'7 ] | idtac ];
 auto.
intros a1 l c l0 H'.
case divP_dec with (1 := cs) (a := a) (b := a1); auto.
apply canonical_nzeroP with (ltM := ltM) (p := l); auto.
intros H'0; left; exists (pX a1 l); auto.
change
  (pickinSetp A A0 eqA multA divA n ltM a (pX a1 l) (mks (pX a1 l) c :: l0))
 in |- *; unfold mks in |- *; auto.
apply (pickinSeteqp A A0 eqA multA divA n ltM); auto.
intros Hyp.
case H'; intros H'1.
inversion H'1.
left; exists x0; auto.
apply pickinSetskip; auto.
right.
intros b p q H'2; inversion_clear H'2; auto.
intros H'3; red in |- *; intros H'4; apply Hyp.
injection H'4.
intros H'5 H'6; rewrite H'6; auto.
Defined.
End Preducestar.


Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Trivial.
Require Import Logic.MinimumLogic.Sound.Sound_Classical_Trivial.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Sound.Sound_Classical_Trivial.

(* TODO: split part of this file into MinimumLogic folder. *)

Instance Pred_minL (A: Type): MinimumLanguage (Pred_L A) := Build_MinimumLanguage (Pred_L A) Semantics.impp.
Instance Pred_pL (A: Type): PropositionalLanguage (Pred_L A) := Build_PropositionalLanguage (Pred_L A) Semantics.andp Semantics.orp Semantics.falsep.

Instance Pred_tminSM (A: Type): TrivialMinimumSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  intros; apply Same_set_refl.
Qed.

Instance Pred_tpSM (A: Type): TrivialPropositionalSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
  + intros; apply Same_set_refl.
  + apply Same_set_refl.
Qed.

Instance Pred_Gamma (A: Type): Provable (Pred_L A) :=
  Build_Provable (Pred_L A) (fun x: expr => forall a: A, x a).

Instance Pred_minAX (A: Type): MinimumAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y ? ? m.
    pose proof @sound_modus_ponens (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y.
    exact (H1 m (H m) (H0 m)).
  + intros x y.
    exact (@sound_axiom1 (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y).
  + intros x y z.
    exact (@sound_axiom2 (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y z).
Qed.

Instance Pred_ipAX (A: Type): IntuitionisticPropositionalLogic (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_andp_intros (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x y).
  + intros x y.
    exact (@sound_andp_elim1 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x y).
  + intros x y.
    exact (@sound_andp_elim2 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x y).
  + intros x y.
    exact (@sound_orp_intros1 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x y).
  + intros x y.
    exact (@sound_orp_intros2 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x y).
  + intros x y z.
    exact (@sound_orp_elim (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x y z).
  + intros x.
    exact (@sound_falsep_elim (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x).
Qed.

Instance Pred_cpGamma (A: Type): ClassicalPropositionalLogic (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  intros x.
  exact (@sound_excluded_middle (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x).
Qed.

Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Semantics.SemanticEquiv.
Require Import Logic.PropositionalLogic.Semantics.Kripke.

Instance Pred_kiSM (A: Type): @KripkeIntuitionisticSemantics (Pred_L A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) :=
  @eqR_KripkeIntuitionistic _ _ _.

Instance Pred_kminSM (A: Type): @KripkeMinimumSemantics (Pred_L A) (Pred_minL A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) :=
  @Trivial2Kripke _ _ _ _ (Pred_tminSM A).

Instance Pred_kpSM (A: Type): @KripkePropositionalSemantics (Pred_L A) (Pred_minL A) (Pred_pL A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) (Pred_kminSM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
  + intros; apply Same_set_refl.
  + apply Same_set_refl.
Qed.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Structure.Limit.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cone.
Require Import Category.Instance.Two.Discrete.

Generalizable All Variables.

Theorem Cartesian_Limit (C : Category) :
  (∀ F : Two_Discrete ⟶ C, Limit F) ↔ @Cartesian C.
Proof.
  split; intros.
  - construct.
    + exact (vertex_obj[X (Pick_Two X0 X1)]).
    + simpl.
      given (cone : Cone (Pick_Two y z)). {
        unshelve (refine {| vertex_obj := x |}); intros.
        unshelve econstructor.
        - destruct x0; simpl; auto.
        - intros. destruct x0, y0; cat;
          pose proof (TwoDHom_inv _ _ f0) as H; inv H.
      }
      destruct (@ump_limits _ _ _ (X (Pick_Two y z)) cone).
      apply unique_obj.
    + simpl.
      destruct (X (Pick_Two x y)).
      destruct limit_cone.
      simpl. change x with (fobj[Pick_Two x y] TwoDX).
      apply (@vertex_map _ _ Two_Discrete (Pick_Two x y) _ TwoDX).
    + simpl.
      destruct (X (Pick_Two x y)).
      destruct limit_cone.
      apply (@vertex_map _ _ Two_Discrete (Pick_Two x y) _ TwoDY).
    + proper.
      apply uniqueness; simpl; intros.
      destruct x2; simpl.
      * rewrite H.
        destruct (ump_limits _).
        apply (unique_property TwoDX).
      * rewrite H0.
        destruct (ump_limits _).
        apply (unique_property TwoDY).
    + simpl.
      destruct (ump_limits _); simpl in *.
      split; intros.
      * split.
        ** rewrite H.
           apply (unique_property TwoDX).
        ** rewrite H.
           apply (unique_property TwoDY).
      * destruct H.
        symmetry.
        apply uniqueness; intros.
        destruct x0; auto.
  - construct.
    + construct; [ exact (product_obj (fobj[F] TwoDX) (fobj[F] TwoDY)) | construct ].
      * destruct x.
        ** apply exl.
        ** apply exr.
      * simpl.
        destruct x, y;
        pose proof (TwoDHom_inv _ _ f) as H; inv H.
        ** now rewrite fmap_id, id_left.
        ** now rewrite fmap_id, id_left.
    + unshelve eexists.
      * apply fork; destruct N; apply vertex_map.
      * intros.
        destruct x; simpl.
        ** now rewrite exl_fork.
        ** now rewrite exr_fork.
      * intros.
        simpl in *.
        rewrite <- !H.
        rewrite fork_comp.
        rewrite fork_exl_exr.
        cat.
Qed.


Require Import ho_proof_until_gen.

Set Implicit Arguments.

Section until_all.

Variables (cfg : Type) (cstep : cfg -> cfg -> Prop).
Definition Spec : Type := cfg -> (cfg -> cfg -> Prop) -> (cfg -> Prop) -> Prop.

(* Soundness *)
CoInductive until (k : cfg) (R : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | rdone : P k -> until k R P
  | rstep : (exists k', cstep k k') ->
            (forall k', cstep k k' -> R k k' /\ until k' R P) -> until k R P.

Definition sound (Rules : Spec) : Prop := subspec Rules until.

Inductive step (X : Spec) (k : cfg) (R : cfg -> cfg -> Prop) (P : cfg -> Prop) : Prop :=
  | sdone : P k -> step X k R P
  | sstep : (exists k', cstep k k') ->
            (forall k', cstep k k' -> R k k' /\ X k' R P) -> step X k R P.

Lemma step_mono : mono step.
Proof.
  destruct 2. constructor. assumption.
  apply sstep. assumption. intros. split. Focus 2. apply H.
  eapply H1. assumption. eapply H1. assumption.
Qed.

Lemma until_stable : subspec until (step until).
Proof. destruct 1; econstructor(assumption). Qed.

CoFixpoint stable_sound (Rules : Spec)
  (Hstable : forall x R P, Rules x R P -> step Rules x R P)
  : sound Rules := fun x R P H =>
match Hstable _ _ _ H with
    | sdone pf => rdone _ _ _ pf
    | sstep not_stuck Hsteps => rstep not_stuck (fun k' Hstep =>
        let (Hpres, Hk') := Hsteps k' Hstep
        in conj Hpres (stable_sound Hstable k' R P Hk'))
end.

Lemma proof_by_t : forall (Rules : Spec), subspec Rules (step (t step Rules)) -> sound Rules.
  intros. apply t_ext in H. apply stable_sound in H. revert H.
  unfold sound, subspec. intros. apply H. apply t_id. trivial. apply step_mono.
Qed.

Definition trans (X:Spec) : Spec :=
  fun k R P => exists Q, X k R Q /\ (forall k', Q k' -> X k' R P).

Lemma mono_trans : mono trans.
Proof.
  destruct 2. inversion H0. econstructor; split. apply H. eassumption.
  intros. apply H. apply H2. trivial.
Qed.

Lemma trans_ok_rule : forall X, subspec (trans X) (t step X).
  apply rule_by_T. apply step_mono. apply mono_trans.
  unfold subspec. intros. destruct H as [Q' [HQ' H]].
  destruct HQ'. specialize (H _ H0). revert H. apply step_mono. apply Tf_id.
  eapply sstep;eauto. intros. split. apply H1. assumption.
  apply Tf_idem. apply step_mono. apply mono_trans.
  apply T_id. exists Q'. split. apply Tf_id. apply H1. assumption.
  intros. specialize (H k'0 H3). apply Tf_base. apply step_mono. assumption.
Qed.

Lemma use_trans : forall A, subspec (trans (t step A)) (t step A).
apply t_rule. firstorder. apply step_mono. apply trans_ok_rule.
Qed.

Lemma tstep: forall F, mono F -> forall A x R P,
      (exists x', cstep x x') ->
      (forall x', cstep x x' -> R x x' /\ T step F A x' R P) -> T step F A x R P.
Proof.
  intros. apply use_step. apply step_mono. assumption. eapply sstep. assumption. assumption.
Qed.

Lemma trule: forall F, mono F -> forall (A : ho_proof_until_gen.Spec cfg) x R P,
      A x R P -> T step F A x R P.
Proof.
  intros. apply Tf_id. trivial.
Qed.

Lemma tdone: forall F, mono F -> forall A x R (P:cfg->Prop), P x -> T step F A x R P.
Proof.
  intros. apply use_step. apply step_mono. assumption. eapply sdone;eassumption.
Qed.

Lemma ttrans: forall F, mono F -> forall A x R Q P,
    T step F A x R Q -> (forall y, Q y -> T step F A y R P) -> T step F A x R P.
Proof.
  intros. apply Tf_idem. apply step_mono. assumption. apply Tf_t. assumption.
  apply trans_ok_rule. unfold trans. exists Q.
  split;assumption.
Qed.

(* X <= step(t X) ==> X <= gfp step *)
(* X <= Step (T X) *)
(* X (step A) <= step ((T X) A) ==> X <= t
   ==> X reaches <= reaches, other stuff *)

(* t_|_ = gfp step ==> t (gfp step) = t (t _|_) = t bot = gfp step *)

(* F : higher order spec  *)
(* F(A) <= step((T F) A)  *)
(* gfp F <= reaches *)
Lemma ok : forall F, mono F ->
    (forall A, subspec (F A) (step (T step F A))) ->
    (forall X, subspec X (F X) -> subspec X until)
    (* == subspec (gfp F) reaches *).
  intros.
  assert (forall A, subspec (F A) (t step A)).
  intros. apply rule_by_T. apply step_mono. apply H.
  unfold subspec;intros. apply H0 in H2. revert H2. apply step_mono.
  unfold subspec;intros. apply Tf_idem. apply step_mono. assumption.
  revert H2. apply T_mono. assumption. apply Tf_base. apply step_mono.
  apply proof_by_t. intro;intros.
  apply H1 in H3. apply H0 in H3.
  revert H3. apply step_mono. apply T_rule_f. apply step_mono. assumption. assumption.
Qed.

End until_all.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import Lists.List.
Require Import ListEx.
Require Import Config.
Require Import Data.
Require Import Monad.

(*

       NAND hardware interface (Version 3)

  NAND Flash is easily to be formalized, due to the sophisicated geography of NAND
flash chips. We follow a common accepted standard, Open NAND FLash Interface (ONFi)
, that published by a few flash manufacturers, Intel, Micron, etc. Please note
we simplify the hardware specification presented in the document, for a reason
that we aim to provide a simple ilustration of NAND flash to developers.

  In the model, we use raw bytes for spare area.

  No NAND chip can be pristine. There are a unknown number of bad blocks in a
new NAND. So manufacturers are responsible to mark them out by setting specifical
cells to 0x00 in a bad block. FTL is supposed to scan all blocks and remember
which are bad and should not be used again. In our model, however, we don't
simulate bad blocks so far. Nevertheless, we shall support bad blocks in next
versions if we model more NAND commands with failure return according to the
standard.

 *)

(* Record chunk (sz: nat) : Set :=  *)
(*   mkchunk {  *)
(*     chunk_data: list byte; *)
(*     chunk_size: length chunk_data = sz *)
(*   }. *)

(* Notation "{{ s }}" := (mkchunk _ s _) (at level 200) : nand_scope. *)
Print blt_nat.

Definition page_off := nat.

Definition block_no := nat.

Definition plane_no := nat.

Definition page_no := prod block_no page_off.

Definition bvalid_block_no (pbn: block_no) : bool :=
  (blt_nat pbn BLOCKS).

Definition bvalid_page_off (off: page_off) : bool :=
  (blt_nat off PAGES_PER_BLOCK).

Definition bvalid_plane_no (pn: plane_no) : bool :=
  (blt_nat pn PLANES).

Inductive page_hw_state : Set :=
  | ps_free
  | ps_programmed
  | ps_invalid.

Record page : Set :=
  mkpage {
      page_data : data;
      page_state : page_hw_state
    }.

Inductive block_hw_status : Set :=
  | bs_normal
  | bs_invalid
  | bs_bad.

Record block : Set :=
  mkblock {
      block_pages : list page;
      block_next_page : page_off;
      block_erase_count: nat;
      block_state : block_hw_status
      (* block_pages_num: length block_pages = PAGES_PER_BLOCK *)
    }.

Definition BLOCKS_PER_PLANE := 1024.

Record plane : Set :=
  mkplane {
      plane_blocks: list block;
      plane_page_register: data
      (* plane_blocks_num : length plane_blocks = BLOCKS_PER_PLANE *)
    }.

Inductive lun_addr : Set :=
  | mklun_addr (pn: plane_no) (b: block_no) (po: page_off) .

Inductive plane_addr : Set :=
  | mkplane_addr (b: block_no) (po: page_off).

Inductive command : Set :=
  | read_start  (* 00h *)
  | read_confirm (* 30h *)
  | read_ID (* 90h *)
  | reset (* FFh *)
  | erase_start (* 60h *)
  | erase_confirm (* D0h *)
  | program_start (* D0h *)
  | program_confirm (* 10h *)
  | read_status (* 70h *).

Definition col_addr := nat.

Definition row_addr := lun_addr.

Definition bvalid_row_addr (ra : row_addr) : bool :=
  match ra with
    | mklun_addr pn b po =>
      match bvalid_plane_no pn with
        | true =>
           match bvalid_block_no b with
             | true  => bvalid_page_off po
             | false => false
           end
        | false => false
      end
end.

Definition bvalid_col_addr (ca : col_addr) : bool :=
  blt_nat ca (PAGE_DATA_SIZE+PAGE_OOB_SIZE).

Definition bvalid_addr (addr : prod row_addr col_addr) : bool :=
  match addr with
    | (ra, ca) =>
       match bvalid_row_addr ra with
         | true => bvalid_col_addr ca
         | false => false
       end
end.

Inductive lun_hw_internal_state : Set :=
  | lun_idle

  | lun_read_wait_addr
  | lun_read_wait_confirm
  | lun_read_busy
  | lun_read_wait_recv

  | lun_prog_wait_addr
  | lun_prog_wait_data
  | lun_prog_wait_confirm
  | lun_prog_busy

  | lun_erase_wait_addr
  | lun_erase_wait_confirm
  | lun_erase_busy

  | lun_read_ID
  | lun_readID_wait_addr
  | lun_read_status.

Record lun: Set :=
  mklun{
      lun_plane0 : plane;
      lun_plane1 : plane;
      lun_cmd_reg: option command;
      lun_addr_reg: option (prod row_addr col_addr) (* row addr. and col addr. *);
      lun_status_RB: bool; (* ready = true, busy = false *)
      lun_status_SF: bool; (* succ = true, fail = false *)
      lun_intern_state: lun_hw_internal_state
    }.

Record target : Set :=
  mktarget {
      target_lun: lun
    }.

Record device : Set :=
  mkdevice {
      device_target: target
    }.

(* ******** Initialization *************** *)

Definition init_page_data : data :=
  list_repeat (PAGE_DATA_SIZE+PAGE_OOB_SIZE) c_null.

Definition init_page : page :=
  mkpage init_page_data ps_free.

Definition init_block : block :=
  mkblock (list_repeat PAGES_PER_BLOCK init_page) 0 0 bs_normal.

Definition init_plane : plane :=
  mkplane (list_repeat BLOCKS_PER_PLANE init_block) nil.

Definition init_lun : lun :=
  mklun init_plane init_plane None None true true lun_idle.

Definition init_target : target :=
  mktarget init_lun.

Definition init_device : device :=
  mkdevice init_target.

(* ********* Nand Internal Operations (over hardware) ************** *)

Definition device_get_plane (d: device) (pn: plane_no) : option plane:=
  check bvalid_plane_no pn;
  do lun <- Some (target_lun (device_target d));
  match pn with
        | 0 => Some (lun_plane0 lun)
        | 1 => Some (lun_plane1 lun)
        | _ => None
  end.

Definition device_set_plane (d: device) (pn: plane_no) (pl:plane) : option device:=
 check bvalid_plane_no pn;
  do lun <- Some (target_lun (device_target d));
  match pn with
        | 0 => Some (mkdevice(mktarget(mklun
                                       pl
                                       (lun_plane1 lun)
                                       (lun_cmd_reg lun)
                                       (lun_addr_reg lun)
                                       (lun_status_RB lun)
                                       (lun_status_SF lun)
                                       (lun_intern_state lun))))
        | 1 => Some (mkdevice(mktarget(mklun
                                       (lun_plane0 lun)
                                       pl
                                       (lun_cmd_reg lun)
                                       (lun_addr_reg lun)
                                       (lun_status_RB lun)
                                       (lun_status_SF lun)
                                       (lun_intern_state lun))))
        | _ => None
  end.

Definition plane_get_block (pl : plane) (ba: block_no) : option block :=
  do b <- list_get (plane_blocks pl) ba;
  Some b.

Definition plane_set_block (pl : plane) (bn: block_no) (b: block): option plane :=
  do bl <- list_set (plane_blocks pl) bn b;
  Some (mkplane bl (plane_page_register pl)).

Definition block_set_invalid (b: block) : option block :=
  Some (mkblock (block_pages b) (block_next_page b) (block_erase_count b) bs_invalid).

Definition page_set_invalid (p: page) : option page :=
  Some (mkpage (page_data p) ps_invalid).

Definition plane_set_block_invalid (pl : plane) (ba: block_no) : option plane :=
  do b  <- plane_get_block pl ba;
  do b' <- block_set_invalid b;
  do bl' <- list_set (plane_blocks pl) ba b';
  Some (mkplane bl' nil).

Definition block_get_page (b: block) (po: page_off) : option page :=
  do p <- list_get (block_pages b) po;
  Some p.

Definition block_set_page (b: block) (po: page_off) (p: page) : option block :=
  check bvalid_page_off po;
  do plst' <- list_set (block_pages b) po p;
  Some (mkblock plst' (S po) (block_erase_count b) bs_normal).

Definition page_get_data (p: page) : option data:=
  Some (page_data p).

Definition plane_get_page (pl: plane) (bn: block_no) (po: page_off) : option page :=
  check bvalid_block_no bn;
  check bvalid_page_off po;
  do b <- plane_get_block pl bn;
  do pgl <- Some (block_pages b);
  do p <- list_get pgl po;
  Some p.

Definition plane_set_page (pl: plane) (bn: block_no) (po: page_off) (p: page) : option plane :=
  check bvalid_block_no bn;
  check bvalid_page_off po;
  do b <- plane_get_block pl bn;
  do pgl <- Some (block_pages b);
  do pgl' <- list_set pgl po p;
  do b' <- Some (mkblock pgl' (S po) (block_erase_count b) bs_normal);
  do pl' <- plane_set_block pl bn b';
  Some pl'.

Definition plane_set_page_invalid (pl: plane) (ba: block_no) (po: page_off) : option plane :=
  do b <- plane_get_block pl ba;
  do p <- block_get_page b po;
  do p' <- page_set_invalid p;
  do pgl' <- list_set (block_pages b) po p';
  do b' <- Some (mkblock pgl' (S (block_next_page b)) (block_erase_count b) bs_normal);
  do bl' <- list_set (plane_blocks pl) ba b';
  Some (mkplane bl' nil).

Definition block_set_erased (ec: nat): block :=
  mkblock (list_repeat PAGES_PER_BLOCK init_page) 0 (S ec) bs_normal.

Definition device_get_block (d: device) (addr: prod row_addr col_addr) : option block :=
  do [raddr, caddr] <- Some addr;
  match raddr with
    | mklun_addr pn bn off =>
      do lun <- Some (target_lun (device_target d));
      do pl <- match pn with
                  | 0 => Some (lun_plane0 lun)
                  | 1 => Some (lun_plane1 lun)
                  | _ => None
                end;
      do b <- plane_get_block pl bn;
      Some b
  end.

(* ******************** Nand chip Operational Semantics ********************** *)

(* Parameter lun_set_intern_state : lun -> lun_hw_internal_state -> lun. *)

(* Parameter block_no_is_odd : nat -> bool. *)

(* Parameter read_plane_data : plane -> plane_addr -> option plane. *)

Definition lun_set_page_invalid (lu: lun) (la: lun_addr) : result lun :=
  match la with
    | mklun_addr pn b po =>
      do pl <-- match pn with
                  | 0 => Some (lun_plane0 lu)
                  | 1 => Some (lun_plane1 lu)
                  | _ => None
                end;
      do pl' <-- plane_set_page_invalid pl b po;
      do lu' <-- match pn with
                    | 0 => Some (mklun pl' (lun_plane1 lu) None None true true lun_idle)
                    | 1 => Some (mklun (lun_plane0 lu) pl' None None true true lun_idle)
                    | _ => None
                  end;
      ret lu'
  end.

Definition lun_set_block_invalid (lu : lun) (la: lun_addr) : result lun :=
  match la with
    | mklun_addr pn b po =>
      do pl <-- match pn with
                  | 0 => Some (lun_plane0 lu)
                  | 1 => Some (lun_plane1 lu)
                  | _ => None
                end;
      do pl' <-- plane_set_block_invalid pl b;
      do lu' <-- match pn with
                    | 0 => Some (mklun pl' (lun_plane1 lu) None None true true lun_idle)
                    | 1 => Some (mklun (lun_plane0 lu) pl' None None true true lun_idle)
                    | _ => None
                  end;
      ret lu'
  end.

Definition send_cmd (d: device) (cmd: command) : result device :=
  match cmd with
    | read_start => match (lun_intern_state (target_lun (device_target d))) with
                      | lun_idle =>
                        let lun := (target_lun (device_target d)) in
                        let lun' := (mklun (lun_plane0 lun)
                                          (lun_plane1 lun)
                                          (Some read_start)
                                          None
                                          true
                                          true
                                          lun_read_wait_addr) in
                        Ok (mkdevice(mktarget lun'))
                      | _ => Unknown
                    end
    | read_confirm =>
         match (lun_intern_state (target_lun (device_target d))) with
           | lun_read_wait_confirm =>
             let lun := (target_lun (device_target d)) in
             let lun' := (mklun (lun_plane0 lun)
                                (lun_plane1 lun)
                                (Some read_confirm)
                                (lun_addr_reg lun)
                                false
                                true
                                lun_read_busy) in
             Ok (mkdevice(mktarget lun'))
           | _ => Unknown
         end

  | read_ID (* 90h *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_idle =>
                        let lun := (target_lun (device_target d)) in
                        let lun' := (mklun (lun_plane0 lun)
                                          (lun_plane1 lun)
                                          (Some read_ID)
                                          None
                                          true
                                          true
                                          lun_read_ID) in
                        Ok (mkdevice(mktarget lun'))
                      | _ => Unknown
                    end

  | reset (* FFh *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_prog_busy =>
                          let lu := (target_lun (device_target d)) in
                          do [la, col] <-- (lun_addr_reg lu);
                          do lu' <== lun_set_page_invalid lu la;
                          ret (mkdevice(mktarget lu'))

                      | lun_erase_busy =>
                          let lu := (target_lun (device_target d)) in
                          do [la, col] <-- (lun_addr_reg lu);
                          do lu' <== lun_set_block_invalid lu la;
                          ret (mkdevice(mktarget lu'))
                      | _ =>
                          let lu := (target_lun (device_target d)) in
                          let lu' := (mklun (lun_plane0 lu)
                                           (lun_plane1 lu)
                                           None
                                           None
                                           true
                                           true
                                           lun_idle) in
                          ret (mkdevice(mktarget lu'))

                    end

  | erase_start (* 60h *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_idle =>
                        let lu := (target_lun (device_target d)) in
                        let lu' := (mklun (lun_plane0 lu)
                                          (lun_plane1 lu)
                                          (Some erase_start)
                                          None
                                          true
                                          true
                                          lun_erase_wait_addr) in
                        Ok (mkdevice(mktarget lu'))
                      | _ => Unknown
                    end

  | erase_confirm (* D0h *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_erase_wait_confirm =>
                        let lu := (target_lun (device_target d)) in
                        let lu' := (mklun (lun_plane0 lu)
                                          (lun_plane1 lu)
                                          (Some erase_confirm)
                                          (lun_addr_reg lu)
                                          false
                                          true
                                          lun_erase_busy) in
                        ret (mkdevice(mktarget lu'))
                      | _ => Unknown
                    end

  | program_start (* D0h *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_idle =>
                        let lu := (target_lun (device_target d)) in
                        let lu' := (mklun (lun_plane0 lu)
                                          (lun_plane1 lu)
                                          (Some program_start)
                                          None
                                          true
                                          true
                                          lun_prog_wait_addr) in
                        Ok (mkdevice(mktarget lu'))
                      | _ => Unknown
                    end

  | program_confirm (* 10h *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_prog_wait_confirm =>
                        let lu := (target_lun (device_target d)) in
                        let lu' := (mklun (lun_plane0 lu)
                                          (lun_plane1 lu)
                                          (Some program_confirm)
                                          (lun_addr_reg lu)
                                          false
                                          true
                                          lun_prog_busy) in
                        ret (mkdevice(mktarget lu'))
                      | _ => Unknown
                    end

  | read_status (* 70h *) =>
                    match (lun_intern_state (target_lun (device_target d))) with
                      | lun_idle =>
                        let lu := (target_lun (device_target d)) in
                        let lu' := (mklun (lun_plane0 lu)
                                          (lun_plane1 lu)
                                          (Some read_status)
                                          None
                                          (lun_status_RB lu)
                                          (lun_status_SF lu)
                                          lun_read_status) in
                        Ok (mkdevice(mktarget lu'))
                      | _ => Unknown
                    end
  end.

Definition device_status := prod bool bool.

Definition recv_status (d: device) : result (prod device_status device) :=
  match (lun_intern_state (target_lun (device_target d))) with
    | lun_read_status =>
      let lu := (target_lun (device_target d)) in
      let sRB := lun_status_RB lu in
      let sSF := lun_status_SF lu in
      let lu' := (mklun (lun_plane0 lu)
                        (lun_plane1 lu)
                        None
                        None
                        (lun_status_RB lu)
                        (lun_status_SF lu)
                        lun_idle) in
      Ok ((lun_status_RB lu, lun_status_SF lu), (mkdevice(mktarget lu')))
    | _ => Unknown
  end.

Definition send_full_addr (d: device) (addr: prod row_addr col_addr) : result device :=
  match (lun_intern_state (target_lun (device_target d))) with
    | lun_read_wait_addr =>
      let lu := (target_lun (device_target d)) in
      let lu' := (mklun (lun_plane0 lu)
                        (lun_plane1 lu)
                        (lun_cmd_reg lu)
                        (Some addr)
                        (lun_status_RB lu)
                        (lun_status_SF lu)
                        lun_read_wait_confirm) in
      Ok (mkdevice(mktarget lu'))

    | lun_prog_wait_addr =>
      let lu := (target_lun (device_target d)) in
      let lu' := (mklun (lun_plane0 lu)
                        (lun_plane1 lu)
                        (lun_cmd_reg lu)
                        (Some addr)
                        (lun_status_RB lu)
                        (lun_status_SF lu)
                        lun_prog_wait_data) in
      Ok (mkdevice(mktarget lu'))

    | _ => Unknown
  end.

Definition send_2cycle_addr (d: device) (addr: (prod plane_no block_no)) : result device :=
  match (lun_intern_state (target_lun (device_target d))) with
    | lun_erase_wait_addr =>
      let lu := (target_lun (device_target d)) in
      let lu' := (mklun (lun_plane0 lu)
                        (lun_plane1 lu)
                        (lun_cmd_reg lu)
                        (Some (mklun_addr (fst addr) (snd addr) 0, 0))
                        (lun_status_RB lu)
                        (lun_status_SF lu)
                        lun_erase_wait_confirm) in
      Ok (mkdevice(mktarget lu'))
    | _ => Unknown
  end.

Definition send_1cycle_addr (d: device) (addr: block_no) : result device :=
  match (lun_intern_state (target_lun (device_target d))) with
    | lun_readID_wait_addr =>
      let lu := (target_lun (device_target d)) in
      let lu' := (mklun (lun_plane0 lu)
                        (lun_plane1 lu)
                        (lun_cmd_reg lu)
                        (Some (mklun_addr (0) (addr) 0, 0))
                        (lun_status_RB lu)
                        (lun_status_SF lu)
                        lun_read_wait_recv) in
      Ok (mkdevice(mktarget lu'))
    | _ => Unknown
  end.

Definition send_data (de: device) (d: data) : result device :=
  match (lun_intern_state (target_lun (device_target de))) with

    | lun_prog_wait_data =>
      do lu <-- Some (target_lun (device_target de));
      do a <-- (lun_addr_reg lu);
      do raddr <-- Some (fst a);
      do pl <-- match raddr with
                  | mklun_addr pn bn po =>
                    match pn with
                      | 0 => Some (lun_plane0 lu)
                      | 1 => Some (lun_plane1 lu)
                      | _ =>  None
                    end
                end;
      do caddr <-- Some (snd a);
      do d' <-- Some (zero_data (caddr));
      do d'' <-- Some (d' ++ d);
      do pl' <-- Some (mkplane (plane_blocks pl) d'');
      do lu' <-- match raddr with
                   | mklun_addr pn bn po =>
                     match pn with
                       | 0 => Some (mklun pl'
                                          (lun_plane1 lu)
                                          (lun_cmd_reg lu)
                                          (lun_addr_reg lu)
                                          (lun_status_RB lu)
                                          (lun_status_SF lu)
                                      lun_prog_wait_confirm)
                       | 1 => Some (mklun (lun_plane0 lu)
                                          pl'
                                          (lun_cmd_reg lu)
                                          (lun_addr_reg lu)
                                          (lun_status_RB lu)
                                          (lun_status_SF lu)
                                      lun_prog_wait_confirm)
                       | _ => None
                     end
                 end;
      ret (mkdevice(mktarget lu'))
    | _ => Unknown
  end.

Definition list_sub {A: Set} (l: list A) (n: nat) : option (list A).
Admitted.

Parameter init_data_ID : data.

Definition recv_data (de: device) : result (prod data device) :=
  match (lun_intern_state (target_lun (device_target de))) with

    | lun_read_wait_recv =>
      do lu <-- Some (target_lun (device_target de));
      do a <-- (lun_addr_reg lu);
      do row <-- Some (fst a);
      do col <-- Some (snd a);
      match row with
           | mklun_addr pn bn po =>
               do pl <-- match pn with
                      | 0 => Some (lun_plane0 lu)
                      | 1 => Some (lun_plane1 lu)
                      | _ =>  None
                    end;
               do lu' <-- match pn with
                                | 0 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   true
                                                   lun_idle)
                                | 1 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   true
                                                   lun_idle)
                                | _ =>  None
                              end;
               do d <-- list_sub (plane_page_register pl) col;
               ret (d, (mkdevice(mktarget lu')))
      end

    | lun_read_ID =>
      do lu <-- Some (target_lun (device_target de));
      do d <-- Some (init_data_ID);
      ret (d, (mkdevice(mktarget (mklun (lun_plane0 lu)
                             (lun_plane1 lu)
                             None
                             None
                             true
                             true
                             lun_idle))))

    | _ => Unknown
  end.

Definition wait_cmd (d: device) : result device :=
  match (lun_intern_state (target_lun (device_target d))) with

    | lun_read_busy =>
      do lu <-- Some (target_lun (device_target d));
      do a <-- (lun_addr_reg lu);
      do row <-- Some (fst a);
      do col <-- Some (snd a);
      do lu' <==
         match row with
           | mklun_addr pn bn po =>
             do pl <-- match pn with
                      | 0 => Some (lun_plane0 lu)
                      | 1 => Some (lun_plane1 lu)
                      | _ =>  None
                    end;
             do b <-- plane_get_block pl bn;
             do pg <-- plane_get_page pl bn po;
             do pl' <-- Some (mkplane (plane_blocks pl) (page_data pg));
             do lu' <-- match pn with
                          | 0 => Some (mklun pl'
                                             (lun_plane1 lu)
                                             None
                                             (lun_addr_reg lu)
                                             true
                                             true
                                             lun_read_wait_recv)
                          | 1 => Some (mklun (lun_plane0 lu)
                                             pl'
                                             None
                                             (lun_addr_reg lu)
                                             true
                                             true
                                             lun_read_wait_recv)
                          | _ => None
                        end;
             ret lu'
         end;
      ret (mkdevice(mktarget lu'))

    | lun_prog_busy =>
      do lu <-- Some (target_lun (device_target d));
      do a <-- (lun_addr_reg lu);
      do raddr <-- Some (fst a);
      do lu' <==
         match raddr with
           | mklun_addr pn bn po =>
             do pl <-- match pn with
                      | 0 => Some (lun_plane0 lu)
                      | 1 => Some (lun_plane1 lu)
                      | _ =>  None
                    end;
             do b <-- plane_get_block pl bn;
             match (block_state b) with
               | bs_bad =>
                   do lu' <-- match pn with
                                | 0 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   false
                                                   lun_idle)
                                | 1 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   false
                                                   lun_idle)
                                | _ =>  None
                              end;
                   ret lu'
               | bs_invalid =>
                   do lu' <-- match pn with
                                | 0 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   false
                                                   lun_idle)
                                | 1 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   false
                                                   lun_idle)
                                | _ =>  None
                              end;
                   ret lu'
               | _ =>
                   do pl' <-- plane_set_page pl bn po (mkpage (plane_page_register pl) ps_programmed);
                   do lu' <-- match pn with
                                | 0 => Some (mklun pl'
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   true
                                                   lun_idle)
                                | 1 => Some (mklun (lun_plane0 lu)
                                                   pl'
                                                   None
                                                   None
                                                   true
                                                   true
                                                   lun_idle)
                                | _ =>  None
                              end;
                   ret lu'
             end
         end;
      ret (mkdevice(mktarget lu'))

    | lun_erase_busy =>

      do lu <-- Some (target_lun (device_target d));
      do a <-- (lun_addr_reg lu);
      do raddr <-- Some (fst a);
      do lu' <==
         match raddr with
           | mklun_addr pn bn po =>
             do pl <-- match pn with
                      | 0 => Some (lun_plane0 lu)
                      | 1 => Some (lun_plane1 lu)
                      | _ =>  None
                    end;
             do b <-- plane_get_block pl bn;
             match (block_state b) with
               | bs_bad =>
                   do lu' <-- match pn with
                                | 0 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   false
                                                   lun_idle)
                                | 1 => Some (mklun (lun_plane0 lu)
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   false
                                                   lun_idle)
                                | _ =>  None
                              end;
                   ret lu'
               | _ =>
                   do pl' <-- plane_set_block pl bn (block_set_erased (block_erase_count b));
                   do lu' <-- match pn with
                                | 0 => Some (mklun pl'
                                                   (lun_plane1 lu)
                                                   None
                                                   None
                                                   true
                                                   true
                                                   lun_idle)
                                | 1 => Some (mklun (lun_plane0 lu)
                                                   pl'
                                                   None
                                                   None
                                                   true
                                                   true
                                                   lun_idle)
                                | _ =>  None
                              end;
                   ret lu'
             end
         end;
      ret (mkdevice(mktarget lu'))

    | _ => Unknown
  end.

(* ******************** Nand chip driver ********************** *)

Definition nand_read_data (de: device) (addr: prod row_addr col_addr) : result (prod data device) :=
  do d0 <== send_cmd de read_start;
  do d1 <== send_full_addr d0 addr;
  do d2 <== send_cmd d1 read_confirm;
  do d3 <== wait_cmd d2;
  do [d, d4] <== recv_data d3;
  Ok (d, d4).

Definition nand_read_spare (de: device) (row: row_addr) : result (prod data device) :=
  do d0 <== send_cmd de read_start;
  do d1 <== send_full_addr d0 (row, PAGE_DATA_SIZE);
  do d2 <== send_cmd d1 read_confirm;
  do d3 <== wait_cmd d2;
  do [d, d4] <== recv_data d3;
  Ok (d, d4).

Definition nand_write_data (de: device) (addr: prod row_addr col_addr) (d: data) : result device :=
  do d0 <== send_cmd de program_start;
  do d1 <== send_full_addr d0 addr;
  do d2 <== send_data d1 d;
  do d3 <== send_cmd d2 program_confirm;
  do d4 <== wait_cmd d3;
  Ok d4.

Definition nand_erase (de: device) (addr: prod plane_no block_no)  : result device :=
  do d0 <== send_cmd de erase_start;
  do d1 <== send_2cycle_addr d0 (addr);
  do d2 <== send_cmd d1 erase_confirm;
  do d3 <== wait_cmd d2;
  Ok d3.

Definition nand_read_ID (de: device) : result (prod data device)  :=
  do d0 <== send_cmd de read_ID;
  do d1 <== send_1cycle_addr d0 0;
  do [d, d2] <== recv_data d1;
  Ok (d, d2).

Definition nand_read_status (d: device): result (prod device_status device) :=
  do d0 <== send_cmd d read_status;
  do [s, d1]  <== recv_status d0;
  Ok (s, d1).

Definition nand_reset (d: device) :result device :=
  do d0 <== send_cmd d reset;
  Ok d0.

(*  -------------------------------------------------------------

  Lemmas

*)

(*Lemma read_spec:
  forall c f lbn off d,
    Inv (c, f)
    -> valid_logical_block_no lbn
    -> valid_page_off off
    -> exists c' f',
         FTL_write c f lbn off d = Some (c', f')
         /\ Inv (c', f')
         /\ FTL_read c' f' lbn off = Some d
         /\ (forall off',
               off' <> off
               -> FTL_read c' f' lbn off' = FTL_read c f lbn off')
         /\ (forall lbn' off',
               lbn' <> lbn
               -> FTL_read c' f' lbn' off' = FTL_read c f lbn' off').
Proof.

 test (bvalid_block_no pbn);

*)

Definition valid_block_no (pbn: block_no) := bvalid_block_no pbn = true.

Definition valid_page_off (off: page_off) := bvalid_page_off off = true.

Definition valid_addr (addr: prod row_addr col_addr) := bvalid_addr addr = true.

Lemma nand_read_data_eq_in_same_block :
  forall c addr c',
    chip_get_block c addr = chip_get_block c' addr
    -> nand_read_data c addr = nand_read_data c' addr.
Proof.

Admitted.
(*
  intros c addr off c'.
  unfold nand_read_data.
  destruct (bvalid_block_no pbn) eqn:Hpbn.
  rewrite <- Hc.
  trivial.
  trivial.
Qed.
*)

Lemma invalid_off_implies_nand_read_page_none :
  forall c addr,
    bvalid_addr addr = false
    -> nand_read_data c addr = Unknown.
Proof.
Admitted.

Definition nand_write_data_sem addr c c' pn bn poff col d lu b:=
  (forall pn',
     pn' <> pn
     -> chip_get_plane c pn' = chip_get_plane c pn)
  /\ (exists pl',
        chip_get_plane c pn = Some pl'
        /\ exists lu',
             lu' = chip_lun c'
             /\ (lun_status_SF lu' = false
                /\ (exists b',
                      plane_get_block pl' bn = Some b'
                      /\ (block_state b' = bs_bad \/ block_state b' = bs_invalid))
                /\ lun_plane0 lu'= lun_plane0 lu
                /\ lun_plane1 lu'= lun_plane1 lu
                /\ lun_cmd_reg lu' = lun_cmd_reg lu
                /\ lun_addr_reg lu' = lun_addr_reg lu
                /\ lun_status_RB lu' = true
                /\ lun_intern_state lu' = lun_idle)
               \/
               (lun_status_SF lu' = true
                /\ (forall addr',
                      addr' <> addr
                      -> chip_get_block c addr' = chip_get_block c' addr'))
             /\ (lun_status_RB lu' = true
                 /\ lun_cmd_reg lu'= None
                 /\ lun_addr_reg lu' = None
                 /\ lun_intern_state lu' = lun_idle
                 /\ (exists b',
                       plane_get_block pl' bn = Some b'
                       /\ block_next_page b' = S poff
                       /\ block_erase_count b' = block_erase_count b
                       /\ block_state b' = bs_normal
                       /\ (exists p', block_get_page b' poff = Some p'
                                      /\ p' = mkpage (zero_data(col) ++ d) ps_programmed))
                )
     ).

Lemma nand_write_data_spec:
  forall c addr pn bn poff col pl b p d lu,
    addr = ((mklun_addr pn bn poff),col:col_addr)
    -> lu = chip_lun c
    -> chip_get_plane c pn = Some pl
    -> plane_get_block pl bn = Some b
    -> block_get_page b poff = Some p
    -> bvalid_page_off poff = true
    -> ble_nat (block_next_page b) poff = true
    -> page_state p = ps_free
    -> exists c' , nand_write_data c addr d = Ok c'
                 /\ nand_write_data_sem addr c c' pn bn poff col d lu b.
                    .

Lemma nand_write_data_spec:
  forall c addr,
    bvalid_addr = true
    -> bvalid_page_off off = true
    -> chip_get_block c pbn = Some b
    -> block_get_page b off = Some p
    -> ble_nat (next_page b) off = true
    -> page_state p = ps_free
    -> exists c', nand_write_page c pbn off d o = Some c'
               /\ (exists b', chip_get_block c' pbn = Some b'
                              /\ next_page b' = S off
                              /\ block_erase_count b' = block_erase_count b
                              /\ block_state b' = bs_programmed
                              /\ (exists p', block_get_page b' off = Some p'
                                            /\ p' = mkpage d o ps_programmed)
                              /\ forall off',
                                   off' <> off
                                   -> bvalid_page_off off' = true
                                   -> block_get_page b' off' = block_get_page b off')
               /\ (forall pbn',
                     pbn' <> pbn
                     -> chip_get_block c pbn' = chip_get_block c' pbn').
Proof.


Require Import MirrorSolve.FirstOrder.

Require Import MirrorSolve.BV.
Require Import MirrorSolve.SMT.
Require Import MirrorSolve.UF.

Require Import MirrorSolve.FOList.

Require Import MirrorSolve.HLists.
Require Import Coq.Lists.List.

Import HListNotations.
Import ListNotations.

Require Import Coq.Strings.String.

Require Import MirrorSolve.Reflection.Core.
Require Import MirrorSolve.Reflection.FM.

Require Import Coq.ZArith.BinInt.

Require Import List.

Section Regexp.
  Variable (Tok : Type).

  Variable (Tok_eqb : Tok -> Tok -> bool).

  Hypothesis (Tok_eqb_spec: forall t1 t2, Tok_eqb t1 t2 = true <-> t1 = t2).

  Inductive Str_tok :=
  | str_nil
  | str_cons : Tok -> Str_tok -> Str_tok.

  Equations app (l: Str_tok) (r: Str_tok) : Str_tok := {
    app str_nil r := r ;
    app (str_cons c cs) r := str_cons c (app cs r);
  }.

  Inductive Regexp : Type :=
  | Zero   : Regexp
  | One    : Regexp
  | Lit    : Tok -> Regexp
  | Plus   : Regexp -> Regexp -> Regexp
  | Times  : Regexp -> Regexp -> Regexp
  | Star   : Regexp -> Regexp.

  Inductive matches : Regexp -> Str_tok -> Prop :=
  | m_One : matches One str_nil
  | m_Lit : forall c, matches (Lit c) (str_cons c str_nil)
  | m_l_Plus : forall R1 R2 s, matches R1 s -> matches (Plus R1 R2) s
  | m_r_Plus : forall R1 R2 s, matches R2 s -> matches (Plus R1 R2) s
  | m_Times : forall R1 R2 s1 s2, matches R1 s1 -> matches R2 s2 -> matches (Times R1 R2) (app s1 s2)
  | m_0_Star : forall R, matches (Star R) str_nil
  | m_n_Star : forall R s1 s2, matches R s1 -> matches (Star R) s2 -> matches (Star R) (app s1 s2).

  Equations emp (R:Regexp) : Regexp := {
    emp Zero := Zero ;
    emp One := One ;
    emp (Lit _) := Zero;
    emp (Plus R1 R2) := Plus (emp R1) (emp R2);
    emp (Times R1 R2) := Times (emp R1) (emp R2);
    emp (Star R) := One
  }.

  Equations is_emp (R:Regexp) : bool := {
    is_emp Zero := false ;
    is_emp One := true ;
    is_emp (Lit _) := false ;
    is_emp (Plus R1 R2) := (is_emp R1) || (is_emp R2) ;
    is_emp (Times R1 R2) := (is_emp R1) && (is_emp R2) ;
    is_emp (Star R) := true
  }.

  Equations deriv (c: Tok) (R:Regexp) : Regexp := {
    deriv _ Zero := Zero ;
    deriv _ One := Zero ;
    deriv c (Lit c') := if Tok_eqb c c' then One else Zero ;
    deriv c (Plus R1 R2) := Plus (deriv c R1) (deriv c R2) ;
    deriv c (Times R1 R2) := Plus (Times (deriv c R1) R2) (Times (emp R1) (deriv c R2)) ;
    deriv c (Star R) := Times (deriv c R) (Star R)
  }.

  Equations derivs (s:Str_tok) (R:Regexp) : bool := {
    derivs str_nil R := is_emp R ;
    derivs (str_cons c s') R := derivs s' (deriv c R)
  }.

  Definition matches_dec (R:Regexp) (s:Str_tok) : bool := derivs s R.

  Declare ML Module "mirrorsolve".

  From MetaCoq.Template Require Import All Loader.
  Import MCMonadNotation.
  Require Import MirrorSolve.Config.
  Open Scope bs.

  Notation pack x := (existT _ _ x).

  Universe foo.
  MetaCoq Quote Definition typ_term := Type@{foo}.

  MetaCoq Run (
    xs <- add_funs typ_term [
        pack Str_tok
      (* ; pack Tok_eqb *)
      ; pack Regexp.app
      ; pack Regexp.Regexp
      ; pack Regexp.emp
      ; pack Regexp.is_emp
      ; pack Regexp.deriv
      ; pack Regexp.derivs
      ; pack Regexp.matches_dec
      ; pack andb
      ; pack orb
    ] [
        pack Regexp.matches
    ];;
    xs' <- tmQuote xs ;;
    tmMkDefinition "trans_tbl" xs'
  ).
  MetaCoq Run (
    gen_sig typ_term sorts fol_funs fol_rels
  ).
  MetaCoq Run (
    gen_interp_funs sorts interp_sorts fol_funs trans_tbl
  ).
  MetaCoq Run (
    gen_interp_rels sorts interp_sorts fol_rels trans_tbl
  ).
  Definition fm_model := Build_model sig interp_sorts interp_funs interp_rels.
  MetaCoq Run (
    add_const_wf_instances sig fm_model trans_tbl
  ).
  MetaCoq Run (
    add_matches sig fm_model trans_tbl
  ).

  MetaCoq Run (
    ctx <- build_printing_ctx sig sort_prop trans_tbl [
          (pack andb, "and"%string)
        ; (pack orb, "or"%string)
        (* ; (pack Tok_eqb, "="%string) *)
      ];;
    ctx' <- tmEval all ctx ;;
    rhs <- tmQuote ctx' ;;
    tmMkDefinition "fol_theory" rhs
  ).

  Require Import MirrorSolve.Reflection.Tactics.

  Transparent denote_tm.
  Require Import MirrorSolve.Axioms.

  Ltac check_goal_unsat :=
    match goal with
    | |- ?G => check_unsat_neg_func fol_theory G; eapply UnsoundAxioms.interp_true
    end.

  Create HintDb regexp_eqns.

  Hint Resolve emp_equation_1 : regexp_eqns.
  Hint Resolve emp_equation_2 : regexp_eqns.
  Hint Resolve emp_equation_3 : regexp_eqns.
  Hint Resolve emp_equation_4 : regexp_eqns.
  Hint Resolve emp_equation_5 : regexp_eqns.
  Hint Resolve emp_equation_6 : regexp_eqns.

  Hint Resolve is_emp_equation_1 : regexp_eqns.
  Hint Resolve is_emp_equation_2 : regexp_eqns.
  Hint Resolve is_emp_equation_3 : regexp_eqns.
  Hint Resolve is_emp_equation_4 : regexp_eqns.
  Hint Resolve is_emp_equation_5 : regexp_eqns.
  Hint Resolve is_emp_equation_6 : regexp_eqns.

  (* Hint Resolve Tok_eqb_spec : regexp_eqns. *)

  Ltac prep_proof :=
    (* hints_foreach (fun x => pose proof x) "regexp_eqns"; *)
    clear Tok_eqb_spec;
    clear Tok_eqb;
    Utils.revert_all;
    unfold "<->" in *.

  Scheme Equality for sorts.

  Ltac quote_reflect := quote_reflect sig fm_model sorts_eq_dec match_tacs match_sorts.

  Ltac mirrorsolve :=
    prep_proof;
    quote_reflect;
    check_goal_unsat.

  Print fol_theory.

  Lemma emp_is_emp : forall R, is_emp R = true -> matches (emp R) str_nil.
  Proof.
    induction R.
    - prep_proof.
      Utils.revert_all.
      quote_reflect.
    mirrorsolve.
    (* induction R ; simpl ; intros ; autorewrite with is_emp in * ; autorewrite with emp in * ;
      try discriminate.
    constructor.
    destruct (is_emp R1) ; destruct (is_emp R2) ; simpl in *.
    constructor ; auto.
    constructor ; auto.
    apply m_r_Plus ; auto.
    discriminate.
    destruct (is_emp R1) ; destruct (is_emp R2) ; simpl in * ; try discriminate.
    replace str_nil with (app str_nil str_nil).
    constructor ; auto. auto.
    constructor. *)
  Qed.

(*** Starting Encoding stuff ***)

Inductive fol_sorts :=
  sort_ascii | sort_list_ascii | sort_regexp | sort_bool.

Definition interp_sorts (x:fol_sorts) : Type :=
  match x with
  | sort_ascii => ascii
  | sort_list_ascii => list ascii
  | sort_regexp => regexp
  | sort_bool => bool
  end.

Inductive fol_regexp_fns : list fol_sorts -> fol_sorts -> Type :=
| nil_f : fol_regexp_fns [] sort_list_ascii
| cons_f : fol_regexp_fns [sort_ascii ; sort_list_ascii] sort_list_ascii
| app_f : fol_regexp_fns [sort_list_ascii ; sort_list_ascii] sort_list_ascii
| eqb_f : fol_regexp_fns [sort_ascii ; sort_ascii] sort_bool
| one_f : fol_regexp_fns [] sort_regexp
| zero_f : fol_regexp_fns [] sort_regexp
| lit_f : fol_regexp_fns [sort_ascii] sort_regexp
| plus_f : fol_regexp_fns [sort_regexp ; sort_regexp ] sort_regexp
| times_f : fol_regexp_fns [sort_regexp ; sort_regexp ] sort_regexp
| star_f : fol_regexp_fns [sort_regexp] sort_regexp
| emp_f : fol_regexp_fns [sort_regexp] sort_regexp
| is_emp_f : fol_regexp_fns [sort_regexp] sort_bool
| andb_f : fol_regexp_fns [sort_bool ; sort_bool] sort_bool
| orb_f : fol_regexp_fns [sort_bool ; sort_bool] sort_bool
| true_f : fol_regexp_fns [] sort_bool
| false_f : fol_regexp_fns [] sort_bool.

Inductive fol_regexp_rels : list fol_sorts -> Type :=
| matches_r : fol_regexp_rels [sort_regexp ; sort_list_ascii].

Definition regexp_sig : signature :=
  {| sig_sorts := fol_sorts ;
    sig_funs := fol_regexp_fns ;
    sig_rels := fol_regexp_rels
  |}.

Equations interp_fun args ret (f:fol_regexp_fns args ret) (hargs: HList.t interp_sorts args) : interp_sorts ret := {
    interp_fun _ _  nil_f _ := nil ;
    interp_fun _ _  cons_f (x:::l:::hnil) := x :: l ;
    interp_fun _ _  app_f (x:::y:::hnil) := x ++ y ;
    interp_fun _ _  eqb_f (x:::y:::hnil) := Ascii.eqb x y ;
    interp_fun _ _  one_f _ := One ;
    interp_fun _ _  zero_f _ := Zero ;
    interp_fun _ _  lit_f (c:::hnil) := Lit c ;
    interp_fun _ _  plus_f (r1:::r2:::hnil) := Plus r1 r2 ;
    interp_fun _ _  times_f (r1:::r2:::hnil) := Times r1 r2 ;
    interp_fun _ _  star_f (r:::hnil) := Star r ;
    interp_fun _ _  emp_f (r:::hnil) := emp r ;
    interp_fun _ _  is_emp_f (r:::hnil) := is_emp r ;
    interp_fun _ _  andb_f (b1:::b2:::hnil) := andb b1 b2 ;
    interp_fun _ _  orb_f (b1:::b2:::hnil) := orb b1 b2 ;
    interp_fun _ _  true_f _ := true ;
    interp_fun _ _  false_f _ := false
    }.

Equations interp_rel args (r: fol_regexp_rels args) (hargs : HList.t interp_sorts args) : Prop := {
    interp_rel _ matches_r (r:::s:::hnil) := matches r s
  }.

Program Definition fm_model : model regexp_sig :=
  {|
    FirstOrder.mod_sorts := interp_sorts ;
    FirstOrder.mod_fns := interp_fun ;
    FirstOrder.mod_rels := interp_rel ;
  |}.

MetaCoq Quote Definition t_nil := @nil.
MetaCoq Quote Definition t_cons := @cons.
MetaCoq Quote Definition t_app := @app.
MetaCoq Quote Definition t_eqb := Ascii.eqb.
MetaCoq Quote Definition t_one := One.
MetaCoq Quote Definition t_zero := Zero.
MetaCoq Quote Definition t_lit := Lit.
MetaCoq Quote Definition t_plus := Plus.
MetaCoq Quote Definition t_times := Times.
MetaCoq Quote Definition t_star := Star.
MetaCoq Quote Definition t_emp := emp.
MetaCoq Quote Definition t_is_emp := is_emp.
MetaCoq Quote Definition t_andb := andb.
MetaCoq Quote Definition t_orb := orb.
MetaCoq Quote Definition t_true := true.
MetaCoq Quote Definition t_false := false.

MetaCoq Quote Definition t_ascii := ascii.
MetaCoq Quote Definition t_list_ascii := (list ascii).
MetaCoq Quote Definition t_regexp := regexp.
MetaCoq Quote Definition t_bool := bool.

MetaCoq Quote Definition t_matches := matches.

Require Import MirrorSolve.Reflection.Tactics.

Notation tac_fun_regexp f := (tac_fun regexp_sig f).
Notation tac_rel_regexp f := (tac_rel regexp_sig f).

Definition match_tacs : list ((term -> bool) * tac_syn regexp_sig fm_model) := [
( fun t => eq_ctor t t_nil, tac_fun_regexp nil_f) ;
( fun t => eq_ctor t t_cons,tac_fun_regexp cons_f) ;
( fun t => eq_ctor t t_app, tac_fun_regexp app_f) ;
( fun t => eq_term t t_eqb, tac_fun_regexp eqb_f) ;
( fun t => eq_term t t_one, tac_fun_regexp one_f) ;
( fun t => eq_term t t_zero, tac_fun_regexp zero_f) ;
( fun t => eq_ctor t t_lit, tac_fun_regexp lit_f);
( fun t => eq_ctor t t_plus, tac_fun_regexp plus_f);
( fun t => eq_ctor t t_times, tac_fun_regexp times_f);
( fun t => eq_ctor t t_star, tac_fun_regexp star_f);
( fun t => eq_term t t_emp, tac_fun_regexp emp_f);
( fun t => eq_term t t_is_emp, tac_fun_regexp is_emp_f);
( fun t => eq_term t t_andb, tac_fun_regexp andb_f);
( fun t => eq_term t t_orb, tac_fun_regexp orb_f);
( fun t => eq_term t t_true, tac_fun_regexp true_f);
( fun t => eq_term t t_false, tac_fun_regexp false_f);
( fun t => eq_term t t_matches, tac_rel_regexp matches_r)
  ].

Definition match_inds : list ((term->bool) * fol_sorts) := [
    (eq_term t_ascii, sort_ascii) ;
    (eq_term t_list_ascii, sort_list_ascii) ;
    (eq_term t_regexp, sort_regexp) ;
    (eq_term t_bool, sort_bool)
  ].

Declare ML Module "mirrorsolve".

RegisterCustomSort sort_ascii "Ascii".

RegisterSMTInd sort_list_ascii (SICases [
      ("cons"%string, [SISort (SCustom "Ascii"); SIRec])
    ; ("nil"%string, [])
  ]) "Ascii_list".

RegisterSMTInd sort_regexp (SICases [
  ("one"%string, []) ;
  ("zero"%string, []) ;
  ("lit"%string, [SISort (SCustom "Ascii")]);
  ("plus"%string, [SIRec ; SIRec]) ;
  ("times"%string, [SIRec ; SIRec]) ;
  ("star"%string, [SIRec])
  ]) "Regexp".

RegisterSMTSort sort_bool SBool.

RegisterSMTUF "app" sort_list_ascii sort_list_ascii sort_list_ascii.
RegisterSMTUF "emp" sort_regexp sort_regexp.
RegisterSMTUF "is_emp" sort_regexp sort_bool.
RegisterSMTUF "matches" sort_regexp sort_list_ascii sort_bool.

RegisterSMTFun nil_f "nil" 0.
RegisterSMTFun cons_f "cons" 2.
RegisterSMTFun app_f "app" 2.
RegisterSMTFun eqb_f "=" 2.
RegisterSMTFun one_f "one" 0.
RegisterSMTFun zero_f "zero" 0.
RegisterSMTFun lit_f "lit" 1.
RegisterSMTFun plus_f "plus" 2.
RegisterSMTFun times_f "times" 2.
RegisterSMTFun star_f "star" 1.
RegisterSMTFun emp_f "emp" 1.
RegisterSMTFun is_emp_f "is_emp" 1.
RegisterSMTFun andb_f "and" 2.
RegisterSMTFun orb_f "or" 2.
RegisterSMTFun true_f "true" 0.
RegisterSMTFun false_f "false" 0.
RegisterSMTFun matches_r "matches" 2.

Transparent denote_tm.
Require Import MirrorSolve.Axioms.

Ltac check_goal_unsat :=
  match goal with
  | |- ?G => check_unsat_neg G; eapply UnsoundAxioms.interp_true
  end.

Create HintDb regexp_eqns.

Hint Resolve emp_equation_1 : regexp_eqns.
Hint Resolve emp_equation_2 : regexp_eqns.
Hint Resolve emp_equation_3 : regexp_eqns.
Hint Resolve emp_equation_4 : regexp_eqns.
Hint Resolve emp_equation_5 : regexp_eqns.
Hint Resolve emp_equation_6 : regexp_eqns.

Hint Resolve is_emp_equation_1 : regexp_eqns.
Hint Resolve is_emp_equation_2 : regexp_eqns.
Hint Resolve is_emp_equation_3 : regexp_eqns.
Hint Resolve is_emp_equation_4 : regexp_eqns.
Hint Resolve is_emp_equation_5 : regexp_eqns.
Hint Resolve is_emp_equation_6 : regexp_eqns.

Lemma matches_one : forall s, matches One s <-> s = nil.
Proof.
  split ; intros ; subst ; auto. inversion H ; auto. constructor.
Qed.
Hint Resolve matches_one : regexp_eqns.

Lemma matches_zero : forall s, matches Zero s <-> False.
Proof.
  split ; intros ; auto. inversion H.
Qed.
Hint Resolve matches_zero : regexp_eqns.

Lemma matches_lit : forall c s, matches (Lit c) s <-> s = c::nil.
Proof.
  intros ; split ; intro. inversion H ; subst ; auto.
  subst ; constructor.
Qed.
Hint Resolve matches_lit : regexp_eqns.

Lemma matches_plus : forall r1 r2 s, matches (Plus r1 r2) s <-> matches r1 s \/ matches r2 s.
Proof.
  intros ; split ; intros.
  inversion H ; auto. destruct H. constructor ; auto. apply m_r_Plus ; auto.
Qed.
Hint Resolve matches_plus : regexp_eqns.

(*
Lemma matches_times : forall r1 r2 s, matches (Times r1 r2) s <-> exists s1, exists s2, s = s1 ++ s2 /\ matches r1 s1 /\ matches r2 s2.
Proof.
  intros ; split ; intros.
  inversion H ; subst.
  eauto.
  destruct H as [s1 [s2 [H1 [H2 H3]]]]. subst ; constructor ; auto.
Qed.
*)

Lemma matches_times1 : forall r1 r2 s1 s2 s3,
  matches r1 s1 ->
  matches r2 s2 ->
  s3 = s1 ++ s2 ->
  matches (Times r1 r2) s3.
Proof.
  intros;
  subst.
  constructor ; auto.
Qed.
Hint Resolve matches_times1 : regexp_eqns.

(*
Lemma matches_star1 : forall r r' s, matches r s -> r = Star r' -> matches One s \/ matches (Times r' r) s.
Proof.
  induction r ; intros ; try discriminate. injection H0 ; intros ; subst.
  inversion H ; subst. left ; constructor.
  admit.

Lemma matches_star : forall r s, matches (Star r) s <-> matches One s \/ matches (Times r (Star r)) s.
Proof.
 *)

Ltac prep_proof :=
    hints_foreach (fun x => pose proof x) "regexp_eqns";
    Utils.revert_all;
    unfold "<->" in *.

Scheme Equality for fol_sorts.

Ltac quote_reflect_list := quote_reflect regexp_sig fm_model fol_sorts_eq_dec match_tacs match_inds.
Ltac quote_extract_list := quote_extract regexp_sig fm_model fol_sorts_eq_dec match_tacs match_inds.

Ltac mirrorsolve :=
    prep_proof;
    quote_reflect_list;
    check_goal_unsat.

Set MirrorSolve Solver "z3".

Lemma app_nil_l:
  forall (x: list ascii), [] ++ x = x.
Proof.
  intros; simpl; trivial.
Qed.

Lemma app_cons_l:
  forall c (l r: list ascii),  (c :: l) ++ r = c :: (l ++ r).
Proof.
  intros; simpl; trivial.
Qed.

Hint Immediate app_nil_l : regexp_eqns.
Hint Immediate app_cons_l : regexp_eqns.

Lemma app_nil_r:
  forall (x: list ascii), x ++ [] = x.
Proof.
  induction x; mirrorsolve.
Qed.

Hint Immediate app_nil_r : regexp_eqns.

Set MirrorSolve Solver "cvc5".

Lemma emp_is_emp' : forall R, is_emp R = true -> matches (emp R) nil.
Proof.
  (* assert (@nil ascii = @nil ascii ++ []) by mirrorsolve. *)
  induction R ;
  try mirrorsolve.
Qed.