Require Import Ynot RSep.
Require Import GradebookModel GradebookApp.
Require Import GradebookTableImpl Store.

Set Implicit Arguments.

Module GradesStoreMapping.
 Export StoreModel.

  Fixpoint Tuple2List' n : Tuple n -> list Grade :=
    match n as n return Tuple n -> list Grade with
      | 0 => fun _ => nil
      | S n => fun x => (fst x) :: (Tuple2List' n (snd x))
    end.

  Definition Tuple2List n (x: Tuple (S n)) :=
    match x with
      | (id, gr) => (id, Tuple2List' n gr)
    end.

  Fixpoint Table2List n (x: Table (S n)) {struct x} : list (ID * list Grade) :=
   match x with
     | nil => nil
     | a :: b => Tuple2List a :: Table2List b
   end.

  Fixpoint List2Tuple' (x: list Grade) n {struct n} : Tuple n :=
    match n as n return Tuple n with
      | S n' => match x with
                  | a :: b => (a, List2Tuple' b n')
                  | nil => (0, List2Tuple' nil n')
               end
      | 0 => tt
    end.

  Definition List2Tuple (x: (ID * list Grade)) n : Tuple (S n) :=
    match x with
      | (id, gr) => List2Tuple' (id :: gr) (S n)
    end.

  Fixpoint List2Table (l: list (ID * list Grade)) n {struct l} : Table (S n) :=
   match l with
     | nil => nil
     | a :: b => List2Tuple a n :: List2Table b n
   end.

   Lemma List2Tuple'_Tuple2List' : forall n t,
     List2Tuple' (Tuple2List' n t) n = t.
     induction n.
     intros; destruct t; auto.
     intros. simpl. rewrite IHn. destruct t. auto.
   Qed.

 Lemma List2Tuple_Tuple2List : forall n a,
   List2Tuple (Tuple2List a) n = a.
   destruct n.
   intros; unfold List2Tuple,Tuple2List. simpl. destruct a. destruct t. auto.
   intros. unfold List2Tuple,Tuple2List. destruct a.
   simpl. rewrite List2Tuple'_Tuple2List'. destruct t; auto.
 Qed.

 Lemma List2Table_Table2List : forall n l,
   List2Table (Table2List l) n = l.
   induction l. reflexivity.
   simpl.
   rewrite List2Tuple_Tuple2List. rewrite IHl. trivial.
 Qed.

(* *)

  Fixpoint nthget' {n} a { struct a }: Tuple n -> option nat :=
    match a with
      | 0 => match n return Tuple n -> option nat with
               | 0 => fun _ => None
               | S n' => fun x => Some (fst x)
             end
      | S a' => match n as n return Tuple n -> option nat with
                  | 0 => fun _ => None
                  | S n'  => fun x => nthget' a' (snd x)
                end
    end.

  Fixpoint nthget n a (l: Table n) {struct l} :=
    match l with
      | nil => None
      | x :: _ => Some (nthget' (S a) x)
    end.

  Fixpoint nthset (size : nat) (idx v' : nat) (tpl : Tuple size) {struct size} : Tuple size :=
    match size as size return Tuple size -> Tuple size with
      | 0 => fun tpl => tpl
      | S n' => fun tpl => match idx with
                             | 0 => (v', snd tpl)
                             | S idx' => (fst tpl, nthset n' idx' v' (snd tpl))
                           end
    end tpl.

  Definition set_query (size : nat) (id : ID) (assign : Assignment) (grade : Grade) (x1 : Tuple (S size)) :=
    if id_dec id (fst x1)
    then Some (fst x1, nthset size assign grade (snd x1))
    else Some x1.

  Definition get_query x cfg :=
    (fun p: Tuple (S (length (totals cfg))) =>
      match p with | (aa,b) => if id_dec aa x then true else false end).

  Lemma lookup_select : forall l c x x0,
    lookup x l = Some x0
    -> exists t, select (get_query x c) (List2Table l (length (totals c))) = List2Table ((x,x0) :: t) _.
    induction l.
      intros; simpl; discriminate.
      intros. simpl in H. simpl. destruct a. simpl.
      remember (id_dec x i) as RM. destruct RM. destruct (id_dec i x); try congruence. rewrite e in *. inversion  H. rewrite H1 in *.
      exists (Table2List (select (get_query i c) (List2Table l (length (totals c))))).
      rewrite List2Table_Table2List. trivial.
      destruct (id_dec i x); try congruence. simpl in IHl. apply IHl; auto.
  Qed.

  Lemma grade_count : forall c l,
    store_inv l c = true
    -> forall x x0, lookup x l = Some x0
      -> length x0 = length (totals c).
    intros. unfold store_inv in *. isTrue (store_inv1 l c) H. pose (inv_bounded l c x H1 H0). apply bounded_length. auto.
  Qed.

  Lemma gg_ret : forall w' l0 n assign,
    n = length l0
    -> nthget' assign (List2Tuple' l0 n) = Some w'
    -> nth_get assign l0 = Some w'.
    induction l0.
      simpl. intros. subst. simpl in *. destruct assign; simpl in *; congruence.
      simpl. intros. subst. simpl in *. destruct assign; simpl in *. auto. eapply IHl0; eauto.
  Qed.

Lemma private_lookup : forall x l c user pass assign grade,
   (private c (GetGrade user pass x assign) = true \/
    private c (SetGrade user pass x grade assign) = true) ->
    store_inv l c = true ->
    exists g', lookup x l = Some g'.
 unfold store_inv in *; unfold private in *; intros. destruct H; all;
  apply (in_dec_total_dec l x c ); trivial.
Qed.

  (** GetGrade Properties **)
(*
  Lemma GetGrade_private_lookup : forall c id pass x a l,
    private c (GetGrade id pass x a) = true ->
    store_inv l c = true ->
    exists g', lookup x l = Some g'.
    intros. simpl in H.
    all. unfold store_inv in H0. all.
.    apply (in_dec_total_dec l x c); auto.
  Qed.
*)
  Theorem GetGrade_store : forall T user pass id assign x (t: Config * T),
    List2Table (snd x) (length (totals (fst t))) = List2Table (snd (snd (mutate (GetGrade user pass id assign) x)))
        (length (totals (fst t))).
  Proof.
    intros. unfold mutate. destruct x. exhaustive ltac:(firstorder).
  Qed.
  Theorem GetGrade_RET_ret : forall T user pass id assign x (t : (Config * T)) w',
    fst x = fst t
    -> store_inv (snd x) (fst t) = true
    -> private (fst t) (GetGrade user pass id assign) = true
    -> nthget assign (select (get_query id (fst t)) (List2Table (snd x) (length (totals (fst t))))) = Some (Some w')
    -> RET w' = fst (mutate (GetGrade user pass id assign) x).
  Proof.
    intros. unfold mutate. destruct x. try rewrite simpl_fst in *; try rewrite simpl_snd in *. rewrite <- H in *.
    rewrite H1. remember (lookup id l) as RM. destruct RM. symmetry in HeqRM. destruct (lookup_select l c id HeqRM). rewrite H3 in H2.
    simpl in H2. inversion H2.

    rewrite (@gg_ret w' l0 (length (totals c)) assign); auto.

    symmetry. eapply grade_count; eauto. pose private_lookup.
    destruct (private_lookup id l c user pass assign 0 (or_introl _ H1)); auto.
    congruence.
  Qed.
  Theorem GetGrade_private_valid : forall (T:Type) x (t:Config * T) user pass id assign,
    fst t = fst x
    -> store_inv (snd x) (fst x) = true
    -> private (fst t) (GetGrade user pass id assign) = true
    -> nthget assign (select (get_query id (fst t)) (List2Table (snd x) (length (totals (fst t))))) = None
    -> False.
  Proof.
    intros. unfold mutate. destruct x. try rewrite simpl_fst in *; try rewrite simpl_snd in *. rewrite <- H in *.
    assert (exists g', lookup id l = Some g'). eapply (  (private_lookup id l (fst t) user pass assign 0 (or_introl _ H1))); eauto.
    destruct H3.
    destruct (lookup_select _ (fst t) _ H3). rewrite H4 in H2. simpl in H2. congruence.
  Qed.
  Theorem GetGrade_BAD_ret : forall T user pass id assign x (t : (Config * T)),
    fst x = fst t
    -> store_inv (snd x) (fst t) = true
    -> private (fst t) (GetGrade user pass id assign) = true
    -> nthget assign (select (get_query id (fst t)) (List2Table (snd x) (length (totals (fst t))))) = Some None
    -> ERR_BADGRADE = fst (mutate (GetGrade user pass id assign) x).
  Proof.
    intros. unfold mutate. destruct x. try rewrite simpl_fst in *; try rewrite simpl_snd in *. rewrite <- H in *. rewrite H1.
    assert (exists g', lookup id l = Some g'). eapply (private_lookup id l c user pass assign 0 (or_introl _ H1)); eauto.
    destruct H3. rewrite H3.
    destruct (lookup_select _ c _ H3). rewrite H4 in H2. simpl in H2.
    simpl in *. all. inversion H2.

    Lemma gg_bad : forall l0 n assign,
      n = length l0
      -> nthget' assign (List2Tuple' l0 n) = None
      -> nth_get assign l0 = None.
      induction l0.
        intros; subst; simpl in *; congruence.
        intros. subst; simpl in *. destruct assign; simpl in *; try congruence. eapply IHl0; eauto.
    Qed.
    rewrite (@gg_bad x (length (totals c)) assign); auto. symmetry. eapply grade_count; eauto.
  Qed.

  (** SetGrade Properties **)

  Theorem SetGrade_OK_store : forall x user pass id assign grade,
    store_inv (snd x) (fst x) = true
    -> private (fst x) (SetGrade user pass id assign grade) = true
    -> inbounds grade assign (totals (fst x)) = true
    -> (update (set_query id assign grade)
      (List2Table (snd x) (length (totals (fst x))))) =
    (List2Table (snd (snd (mutate (SetGrade user pass id assign grade) x)))
      (length (totals (fst x)))).
  Proof.
    intros. unfold mutate. destruct x. rewrite simpl_fst in *. rewrite simpl_snd in *.
      rewrite H0. rewrite H1. destruct (private_lookup id l c user pass assign grade (or_intror _ H0)). trivial. rewrite H2.
      simpl. unfold store_inv in H. all.

      Lemma proof' : forall c x grade assign id l,
        lookup id l = Some x
        -> length x = length (totals c)
        -> noduples (students c) l = true
        -> update (set_query id assign grade)
        (List2Table l (length (totals c))) =
        List2Table (insert id (nth_set grade assign x) l) (length (totals c)).
        induction l.
          simpl. congruence.
          intros. remember (id_dec id (fst a)) as RM. destruct RM.
            simpl in H. destruct a. simpl in e. unfold set_query. simpl.
            destruct (id_dec id i); try congruence.
            destruct (id_dec i id); try congruence. simpl.
            simpl in H1. remember (lookup i l) as RM'; destruct RM'; try congruence.
            repeat inv auto.
            Lemma nthset_nth_set : forall grade l0 n assign,
              n = length l0
              -> nthset n assign grade (List2Tuple' l0 n) = List2Tuple' (nth_set grade assign l0) n.
              induction l0.
                intros; subst; reflexivity.
                intros. subst. simpl. destruct assign. inv auto. inv auto.
            Qed.
            inversion H. rewrite <- H4 in *. apply nthset_nth_set; auto.
            pose (denoteLookupNone _ HeqRM').
            Lemma updateNone : forall id assign grade c l,
              (forall (x : ID) (t' : list Grade), In (x, t') l -> x <> id)
              -> update (set_query id assign grade) (List2Table l (length (totals c))) =
                 List2Table l (length (totals c)).
              induction l.
                firstorder.
                intros. unfold set_query. simpl. destruct a. simpl. destruct (id_dec id i). pose (H i l0 (in_eq  _ _)); congruence.
                simpl in H. assert (forall (x : ID) (t' : list Grade), In (x, t') l -> x <> id). intros. eapply H; eauto.
                pose (IHl H0). unfold set_query in e. simpl in e. rewrite e. auto.
            Qed.
            pose (e2 := @updateNone i assign grade c l n). unfold set_query in e2. simpl in e2. rewrite e1 in *; auto.

          simpl. unfold set_query. destruct a. simpl. simpl in HeqRM, n. rewrite <- HeqRM. destruct (id_dec i id); try congruence.
          simpl. inv auto. apply IHl; auto. simpl in H. rewrite <- HeqRM in H. auto. simpl in H1. destruct (lookup i l); try congruence. all; auto.
       Qed.
     apply proof'. auto. eapply grade_count; eauto. unfold store_inv. each; auto. auto.
  Qed.

  Theorem SetGrade_OK_ret : forall x user pass id assign grade,
    store_inv (snd x) (fst x) = true
    -> private (fst x) (SetGrade user pass id assign grade) = true
    -> inbounds grade assign (totals (fst x)) = true
    -> OK = fst (mutate (SetGrade user pass id assign grade) x).
  Proof.
    intros. unfold mutate. destruct x. rewrite simpl_fst in *. rewrite simpl_snd in *.
      rewrite H0. rewrite H1. destruct (private_lookup id l c user pass assign grade (or_intror _ H0)). trivial. rewrite H2.
      auto.
  Qed.

  Theorem SetGrade_BAD_store : forall x user pass id assign grade,
    store_inv (snd x) (fst x) = true
    -> private (fst x) (SetGrade user pass id assign grade) = true
    -> inbounds grade assign (totals (fst x)) = false
    -> List2Table (snd (snd (mutate (SetGrade user pass id assign grade) x)))
    (length (totals (fst x))) = List2Table (snd x) (length (totals (fst x))).
  Proof.
    intros. unfold mutate. destruct x. simpl in *. rewrite H0. rewrite H1. reflexivity.
  Qed.

  Theorem SetGrade_BAD_ret : forall x user pass id assign grade,
    store_inv (snd x) (fst x) = true
    -> private (fst x) (SetGrade user pass id assign grade) = true
    -> inbounds grade assign (totals (fst x)) = false
    -> ERR_BADGRADE = fst (mutate (SetGrade user pass id assign grade) x).
    intros; unfold mutate. destruct x. rewrite simpl_fst in *. rewrite simpl_snd in *.
      rewrite H0. rewrite H1. auto.
  Qed.

  (** Average Properties **)

  Lemma project_preserves_length : forall n n' F l,
    length l = length (@project (S n) n' F (List2Table l n)).
    induction l. reflexivity. simpl. rewrite IHl. auto.
  Qed.

  Fixpoint fn (tbl: Table 1) : list Grade :=
    match tbl with
      | nil => nil
      | (a :: b) => ((fst a :: fn b))
    end.

  Lemma fn_preserves_length : forall (l:Table 1), length l = length (fn l).
    induction l; auto.  simpl. rewrite <- IHl. trivial.
  Qed.

  Lemma NoEntriesNoStudents : forall T (s:list ID), total_dec s (@nil (ID * T)) = true -> s = nil.
    intros. simpl in *. destruct s. trivial. simpl in H; discriminate.
  Qed.

  Lemma lm2 : forall l c, store_inv l c = true -> length l = length (students c).
    unfold store_inv. intros. all. clear F1. destruct c. simpl in *. unfold config_inv in H. all. clear H F1. simpl in F2.
    generalize dependent students0.
    clear tas0 profs0 sections0 hashes0 totals0.
    remember (length l) as RM. generalize dependent l.
    induction RM.
      intros. destruct l. pose (NoEntriesNoStudents _ _ F0). rewrite e. auto. simpl in *; congruence.
      intros. remember l as ll. destruct ll; try (simpl in *; congruence). simpl in *. inversion HeqRM.

      Fixpoint remove (T : Type) (d : forall (a b : T), {a = b} + {a <> b}) (l : list T) (t : T) {struct l} : list T :=
        match l with
          | nil => nil
          | a :: b => if d a t then remove d b t else a :: remove d b t
        end.

      pose (IHRM ll H0 (remove id_dec students0 (fst p))). rewrite <- H0. rewrite e.

      Lemma nodup_totals : forall s p ll,
        unique id_dec s = true
        -> noduples s (p :: ll) = true
        -> total_dec s (p :: ll) = true
        -> noduples (remove id_dec s (fst p)) ll = true /\
           total_dec (remove id_dec s (fst p)) ll = true.

       intros. destruct p. simpl in *. remember (lookup i ll) as RM. destruct RM; try congruence.
       Lemma noduples_remove : forall ll s x,
         lookup x ll = None -> noduples s ll = true -> noduples (remove id_dec s x) ll = true.
            induction ll.
              reflexivity.
              intros. simpl. destruct a. rewrite simpl_fst in *. cut (lookup i ll = None). intro. rewrite H1.
              each. simpl in H0. rewrite H1 in H0. all.
              Lemma in_dec_in : forall i s x,
                in_dec i s = true -> i <> x -> in_dec i (remove id_dec s x) = true.
                induction s.
                  simpl; congruence.
                  intros. simpl. destruct (id_dec a x). unfold in_dec in H. rewrite e in *. destruct (id_dec i x); try congruence. auto.
                  simpl. destruct (id_dec i a); try congruence. apply IHs; auto. simpl in H. destruct (id_dec i a); try congruence.
              Qed.
              apply in_dec_in; auto. unfold not. intro. subst. simpl in H. destruct (id_dec x x); congruence.
              apply IHll; auto. unfold lookup in H. destruct (id_dec x i); try congruence. auto.
              simpl in H0. rewrite H1 in H0. all; auto. simpl in H0. destruct (lookup i ll); try congruence.
        Qed.
        split. all. apply noduples_remove; auto.
        Lemma total_dec_remove : forall T s i (l:T) ll,
          unique id_dec s = true
          -> total_dec s ((i,l) :: ll) = true
          -> total_dec (remove id_dec s i) ll = true.
          induction s.
            reflexivity.
            intros. simpl in *. remember (id_dec a i) as RM. destruct RM. remember (In_dec id_dec a s) as RM'. destruct RM'; try congruence.
            rewrite <- e in *. eapply IHs; eauto.

            destruct (In_dec id_dec a s); try congruence. simpl. destruct (lookup a ll); try congruence. eapply IHs; eauto.
        Qed.
        eapply total_dec_remove; eauto.
      Qed.

      Lemma remove_notin : forall T dec (x : T) s,
        ~In x s
        -> s = remove dec s x.
        induction s.
          simpl; auto.
          simpl. intros. destruct (dec a x). subst. tauto. rewrite <- IHs; auto.
      Qed.

      Lemma remove_unique : forall T dec (x:T) s,
        unique dec s = true
        -> In x s
        -> length s = S (length (remove dec s x)).
        induction s.
          simpl; intros. inversion H0.
          intros. simpl. inv auto. destruct H0. subst.
            destruct (dec x x); try congruence. simpl in H. destruct (In_dec dec x s); try congruence.
            rewrite <- remove_notin; auto.
            destruct (dec a x). simpl in H. destruct (In_dec dec a s); try congruence. rewrite <- remove_notin; auto. subst; auto.
            apply IHs; auto. simpl in H. destruct (In_dec dec a s); try congruence.
      Qed.
      rewrite (@remove_unique _ id_dec (fst p) students0); auto.
      destruct (lookup (fst p) ll); try congruence. all. apply denoteInDec; auto.
      destruct (@nodup_totals students0 p ll F2 F F0); auto.
      destruct (@nodup_totals students0 p ll F2 F F0); auto.
      Lemma remove_preserves_unique : forall T dec (x :T) s,
        unique dec s = true -> unique dec (remove dec s x) = true.
        induction s.
          auto.
          intros. simpl. simpl in H. destruct (In_dec dec a s); try congruence. destruct (dec a x).
            apply IHs; auto.
            simpl. rewrite IHs; auto.
            destruct (In_dec dec a (remove dec s x)); auto.
            Lemma remove_not : forall T dec (a x : T) s,
              ~In a s -> ~In a (remove dec s x).
              induction s; [ auto | ] .
              intuition. simpl in H0. simpl in H. destruct (dec a0 x). subst.
              contradiction. simpl in H0. destruct H0. subst. auto. auto.
            Qed.
            apply (remove_not dec a x) in n. contradiction.
      Qed.
    apply remove_preserves_unique; auto.
  Qed.

  Lemma lm3 : forall l ,
    aggregate (fun (a : nat) (x0 : Tuple 1) => fst x0 + a) 0 l = sum_all (fn l).
    induction l. auto. simpl in *. rewrite IHl. trivial.
  Qed.

  Opaque GET_COL.
  Lemma lm4 : forall l c assign pfx2,
    store_inv l c = true ->
    Some(fn
      (project (@GET_COL (S (length (totals c))) (S assign) pfx2)
        (List2Table l (length (totals c))))) = proj assign l.
    intros. assert (forall (x : ID) (x0 : list Grade), lookup x l = Some x0 -> length x0 = length (totals c)). intros; eapply grade_count; eauto.
    unfold store_inv in H. assert (config_inv c = true). all; auto.  rewrite H1 in H.
    assert (
        (andb (andb (store_inv1 l c) (total_dec (students c) l))
           (noduples (students c) l)) = true).  all; each; auto.  clear H.  rename H2 into H. clear H1. all. clear F. clear F0. generalize dependent H0. intro.
    induction l.
      simpl. trivial.
      Lemma nth_get_less' : forall (T : Type) id l a (t:list T) pfx2,
      length l = length t
      -> a < length l
      -> nth_get a l = Some (fst (@GET_COL (S (length t)) (S a) pfx2 (List2Tuple (id,l) (length t)))).
        induction l.
      simpl. intros. elimtype False. omega.
      intros. rewrite GET_COL_projs. rewrite <- H.
      destruct a0; auto.
          simpl. Opaque GET_COL. simpl in *. destruct t. simpl in H. congruence.
          simpl in H.  inversion H. rewrite H2 in H0.
          pose (@IHl a0 t0 H0). rewrite e; auto. rewrite GET_COL_projs. simpl. rewrite H2. auto. omega.
      Qed.
      unfold proj. Opaque GET_COL. simpl. fold proj. rewrite <- IHl.
      pose (H0 (fst a) (snd a)).
      assert (length (snd a) = length (totals c)). apply e; destruct a; compute; destruct (id_dec i i); auto. congruence.
      rewrite (@nth_get_less' _ (fst a) (snd a) assign (totals c) pfx2); auto. destruct a. auto.
      rewrite H1; omega. intros. simpl in H. destruct (lookup (fst a) l); try congruence. all. auto. intros. apply (H0 x). simpl. destruct a. destruct (id_dec x i); auto.
      simpl in H. subst; rewrite H1 in H. congruence.
    Qed.

  Theorem AvgRet : forall v x1 y l c assign user pass
    (pfx2: assign < length (totals c))
    (H1 : y = aggregate (fun (a : nat) (x0 : Tuple 1) => fst x0 + a) 0 x1)
    (H2 : v = RET (divcheck0 y (length (students c))))
    (H3 : x1 = project (GET_COL (Lt.lt_n_S _ _ pfx2))
      (List2Table l (length (totals c ))))
    (H4 : store_inv l c = true)
    (H5 : private c (Average user pass assign) = true),
    v = fst (mutate (Average user pass assign) (c, l)).

    intros. unfold mutate. rewrite H5. destruct (validAssignment c assign); try solve [ elimtype False; omega ].
    cut (Some (fn (project (GET_COL (Lt.lt_n_S _ _ pfx2))
      (List2Table l (length (totals c))))) = proj assign l ). intros jj.
    rewrite <- jj. unfold avg.
    cut (y = sum_all (fn (project (GET_COL (Lt.lt_n_S _ _ pfx2)) (List2Table l (length (totals c)))))). intros jj2. rewrite <- jj2.
    cut (length (students c) = length (fn (project (GET_COL (Lt.lt_n_S _ _ pfx2)) (List2Table l (length (totals c)))))). intros jj3. rewrite <- jj3. auto.
    cut (length l = length (students c)). intros jj4. rewrite <- jj4 .
    rewrite (@project_preserves_length (length (totals c)) 1 (GET_COL (Lt.lt_n_S _ _ pfx2)) l).
    apply fn_preserves_length.
    apply (lm2 ). trivial.
    rewrite H1. rewrite <- H3. apply lm3. apply lm4; trivial.
  Qed.

  Theorem AverageStore : forall user pass assign c l,
    List2Table l (length (totals c)) =
    List2Table (snd (snd (mutate (Average user pass assign) (c,l))))
    (length (totals c)).
  Proof.
    intros. unfold mutate.  exhaustive ltac:(firstorder).
  Qed.

  Theorem AvgBad : forall l c assign user pass
    (pfx1 : assign >= length (totals c))
    (H1 : store_inv l c = true)
    (H2 : private c (Average user pass assign) = true),
    ERR_BADGRADE = fst (mutate (Average user pass assign) (c,l)).
    intros. unfold mutate. rewrite H2. destruct (validAssignment c assign); auto. elimtype False. omega.
  Qed.

End GradesStoreMapping.

Module GradebookStoreImpl (s: Store) : GradebookImpl.
(* Export GradesTableMapping. *)
  Export GradesStoreMapping.

  Definition T := (Config * s.t)%type.

 Open Scope hprop_scope.

  Definition rep (t: T) (m: (Config * list (ID * (list Grade)))) : hprop
    := [fst t = fst m] * s.rep (snd t) (List2Table (snd m) (length (totals (fst t)))).

  Open Scope stsepi_scope.

  (* set branch impl *)
  Definition F_set user pass id assign grade m t :
    STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] *
              [private (fst t) (SetGrade user pass id assign grade) = true])
          (fun r : Status => m ~~ [r  = fst (mutate (SetGrade user pass id assign grade)  m)] *
              rep t (snd (mutate (SetGrade user pass id assign grade) m)) * [store_inv (snd m) (fst m) = true]).
    intros. unfold T in *. refine (
      let cfg := fst t in
      let st := snd t in
      (match inbounds grade assign (totals cfg) as ib
         return inbounds grade assign (totals cfg) = ib -> _
         with
         | true => fun pf =>
           s.update st (set_query id assign grade) (m ~~~ List2Table (snd m) (length (totals cfg))) <@> _ ;;
           {{ Return OK }}
         | false => fun pf =>
           {{ Return ERR_BADGRADE }}
       end) (refl_equal _)
    ); unfold rep; unfold st; unfold cfg.
    solve [ do 2 rsep fail auto ].
    solve [ rsep fail auto ].
    solve [ rsep fail auto ].

    (** It would be nice to get these with hints. **)
    Hint Resolve SetGrade_OK_store.
    Hint Resolve SetGrade_OK_ret.
    Hint Resolve const_config.
    solve [ rsep fail auto; unfold cfg in *; rewrite H4 in *;
      rewrite <- (SetGrade_OK_ret x user pass id assign grade H2 H3 pf);
      rewrite <- (SetGrade_OK_store _ _ _ _ _ _ H2 H3 pf); rsep fail auto ].
    solve [ rsep fail auto ].

    Hint Resolve SetGrade_BAD_store.
    Hint Resolve SetGrade_BAD_ret.
    solve [ rsep fail auto; unfold cfg in *; rewrite H0 in *;
      rewrite (SetGrade_BAD_store _ _ _ _ _ _ H1 H2 pf);
      rewrite (SetGrade_BAD_ret _ _ _ _ _ _ H1 H2 pf); rsep fail auto ].
  Qed.

  (* type of error computations *)
  Definition F_err_t (e: Status) := STsep __ (fun r => [e = r]).

  Definition F_get : forall user pass id assign m t,
    STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] *
              [private (fst t) (GetGrade user pass id assign) = true])
          (fun r : Status => m ~~ [r  = fst (mutate (GetGrade user pass id assign)  m)] *
              rep t (snd (mutate (GetGrade user pass id assign) m)) * [store_inv (snd m) (fst m) = true]).
    refine (fun user pass id assign m t =>
      xx <- s.select (snd t) (get_query id (fst t)) (m ~~~ List2Table (snd m)  (length (totals (fst t))) ) <@> _ ;
      match nthget assign xx as R return  nthget assign xx = R  -> _  with
        | None => fun pf => {{ !!! }}
        | Some w => fun pf => match w as w' return w = w' -> _ with
                                | None =>    fun pf2 =>  {{ Return ERR_BADGRADE }}
                                | Some w' => fun pf2 =>  {{ Return (RET w')
                                  <@> (m ~~ [fst t = fst m] * [store_inv (snd m) (fst t) = true] * [private (fst t) (GetGrade user pass id assign) = true]) }}
                              end (refl_equal _)
      end  (refl_equal _ )  ).
    unfold rep; do 2 rsep fail auto.
    rsep fail auto.
    rsep fail auto. rewrite <- H4. rsep fail auto.
    unfold rep; rsep fail auto. rewrite <- H4. rsep fail auto.

    rewrite H0 in pf. rewrite pf2 in pf. auto.
    rewrite (GetGrade_RET_ret user pass id assign x t); auto. rsep fail auto.
    rewrite <- (@GetGrade_store _ user pass id assign x t); auto. rsep fail auto.
    pose (const_config2 x t (GetGrade user pass id assign)). rsep fail auto.
    rsep fail auto.
    unfold rep; rsep fail auto.
    rewrite (GetGrade_BAD_ret user pass id assign x t); auto. rsep fail auto.
    rewrite <- (@GetGrade_store _ user pass id assign x t); auto. rsep fail auto.
    pose (const_config2 x t (GetGrade user pass id assign)). rsep fail auto. rewrite H5; auto. rewrite (pack_injective H0). rewrite H1 in pf. rewrite pf2 in pf. trivial.
    rsep fail auto.
    elimtype False. apply (@GetGrade_private_valid _ x t user pass id assign); auto. rewrite <- (pack_injective H0) in *. subst. auto.
    rsep fail auto.
  Qed.

Require Import Lt.
Definition F_avg : forall user pass assign m t,
  STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] *
    [private (fst t) (Average user pass assign) = true])
  (fun r : Status => m ~~ [r  = fst (mutate (Average user pass assign)  m)] *
    rep t (snd (mutate (Average user pass assign) m)) * [store_inv (snd m) (fst m) = true]).
  refine (fun user pass assign m t =>
  match validAssignment (fst t) assign with
    | left pf =>
      x <- s.project (snd t) (@GET_COL _ (S assign) (lt_n_S _ _ pf)) (m ~~~ List2Table (snd m)  (length (totals (fst t)))) <@> _  ;
      y <- s.aggregate (fst x) (fun a (x0: Tuple 1) => (fst x0) + a) 0 (snd x) <@> _ ;
      s.free (fst x) (snd x) <@> _ ;;
      {{ Return (RET (divcheck0 y (length (students (fst t))))) }}
    | right pf =>
      {{ Return ERR_BADGRADE }}
  end).
 unfold rep. rsep fail auto.
 rsep fail auto.
 unfold rep. rsep fail auto.
 unfold rep. rsep fail auto.
 unfold rep. rsep fail auto.
 unfold rep. rsep fail auto.
 unfold rep. rsep fail auto.
 rsep fail auto.
 unfold rep. rsep fail auto. destruct t. destruct x0. simpl in H3. simpl in H5. subst c0.
 pose (@AvgRet v x1 y l c assign user pass pf H1 H6 H2 H3 H4).
 rewrite e.
 pose (const_config2  (c, l) (c, l) (Average user pass assign)).
 pose (rr := AverageStore user pass assign c l ). Opaque mutate. simpl.
rewrite rr. rsep fail auto.
 rsep fail auto.
 unfold rep. rsep fail auto. rsep fail auto.
 unfold rep. rsep fail auto. destruct t. destruct x. simpl in H3. simpl in H0. subst c0.
 pose (@AvgBad l c assign user pass pf H1 H2).
 rewrite e.
 pose (const_config2  (c,l) (c,l) (Average user pass assign) (refl_equal (fst (c,l)))).
 pose (rr := AverageStore user pass assign c l). Opaque mutate. simpl.
 rewrite rr. rsep fail auto.
Qed.

(* The overall computation just stiches the branches together. *)
Definition F : forall (q: Command) m t,
  STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] * [private (fst t) q = true])
        (fun r : Status => m ~~ [r  = fst (mutate q m)] *
               rep t (snd (mutate q m)) * [store_inv (snd m) (fst m) = true]).
refine (fun q m t =>
  match q as q
    return STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] * [private (fst t) q = true])
                 (fun r : Status => m ~~ [r  = fst (mutate q m)] *
                     rep t (snd (mutate q m)) * [store_inv (snd m) (fst m) = true])
    with
    | GetGrade id pass x a   =>  F_get id pass x a m t
    | SetGrade id pass x a g =>  F_set id pass x a g m t
    | Average  id pass a     =>  F_avg id pass a m t
  end).
Qed.

(* Then we just {{ }} it to the proper type for exec. *)
Definition exec' : forall (t : T) (q : ParseCommand) (m : [(Config * list (ID * (list Grade)))]),
  STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] )
  (fun r : Status => m ~~ [r  = fst (mutate (compileCommand (fst m) q) m)] *
    rep t (snd (mutate (compileCommand (fst m) q) m)) * [store_inv (snd m) (fst m) = true] ).
refine (fun t q m =>
let q := compileCommand (fst t) q in
{{match private (fst t) q as p'
    return STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true] * [private (fst t) q = p'])
                 (fun r : Status => m ~~ [r  = fst (mutate q m)] *
                   rep t (snd (mutate q m)) * [store_inv (snd m) (fst m) = true])
    with
    | true => F q m t
    | false => {{ Return  ERR_NOTPRIVATE }}
  end}}).
  rsep fail auto.
  unfold q0.
  destruct t. hdestruct m. unfold rep. rsep fail auto. Opaque mutate. simpl in *. subst.
  sep fail auto. Transparent mutate. unfold mutate. destruct (private c0 (compileCommand c0 q)). discriminate.
   simpl in *. sep fail auto.
 unfold rep, q0; rsep fail auto.
 unfold rep,q0.
 rsep fail auto. cut (fst t = fst x). intro. rewrite H3. rsep fail auto.
 rewrite H1. symmetry. apply const_config.
Qed.

Export ExampleConfig.
  Definition init :
    STsep (__)
          (fun tm : T * [(Config * list (ID * (list Grade)))] => hprop_unpack (snd tm)
            (fun m => rep (fst tm) m * [store_inv (snd m) (fst m) = true])).
    refine (
      x <- s.new (S (length (totals test_config))) ;
      s.insert x (n:=(S (length (totals test_config)))) ((4,(65,(63,(75,tt))))::nil) _;;
      s.insert x (n:=(S (length (totals test_config)))) ((5,(68,(76,(80,tt))))::nil) _;;
      s.insert x (n:=(S (length (totals test_config)))) ((6,(70,(80,(94,tt))))::nil) _;;
      {{ Return ((test_config, x), inhabits test_model) }});
    unfold rep; pose test_cfg_inv; rsep fail auto.
    subst. simpl in *. eapply pack_injective in H0. subst. rsep fail auto.
  Qed.

  Definition cleanup : forall (t : T) (m : [(Config * list (ID * list Grade))]),
    STsep (m ~~ rep t m * [store_inv (snd m) (fst m) = true])
          (fun _:unit => __).
    refine (fun t m => {{s.free (snd t) (m ~~~ List2Table (snd m) (length (totals (fst t)))) }});
    unfold rep; sep fail auto.
  Qed.

End GradebookStoreImpl.

Module some_store : Store := ListStore.
Module the_app' := GradebookStoreImpl some_store.
Module theApp : GradebookType := GradebookApp.Gradebook the_app'.

Require Import GradebookInterface.
Module http_interface := HttpGradebookInterface theApp.

Require Import HttpServer.
Module http_server := HttpServer.HttpAppStateParams theApp http_interface.
Module mod_http := TcpServer.ExecImpl http_server.

Definition http := mod_http.main.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl 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.

  VPrl 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 VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents.
Require Export lift_lsubst_tacs.

Ltac free_vars_rw :=
  match goal with
    | [ |- context[free_vars (mk_isaxiom  _ _ _)] ] => rewrite free_vars_isaxiom
    | [ |- context[free_vars (mk_equality _ _ _)] ] => rewrite free_vars_equality

    | [ |- context[free_vars (mk_union     _ _)] ] => rewrite free_vars_union
    | [ |- context[free_vars (mk_bunion    _ _)] ] => rewrite free_vars_bunion
    | [ |- context[free_vars (mk_uand      _ _)] ] => rewrite free_vars_uand
    | [ |- context[free_vars (mk_apply     _ _)] ] => rewrite free_vars_apply
    | [ |- context[free_vars (mk_tequality _ _)] ] => rewrite free_vars_tequality
    | [ |- context[free_vars (mk_approx    _ _)] ] => rewrite free_vars_approx

    | [ |- context[free_vars mk_axiom] ] => rewrite free_vars_axiom
    | [ |- context[free_vars mk_base]  ] => rewrite free_vars_base
    | [ |- context[free_vars mk_bool]  ] => rewrite free_vars_bool
    | [ |- context[free_vars mk_unit]  ] => rewrite free_vars_unit

    | [ H : context[free_vars (mk_isaxiom  _ _ _)] |- _ ] => rewrite free_vars_isaxiom in H
    | [ H : context[free_vars (mk_equality _ _ _)] |- _ ] => rewrite free_vars_equality in H

    | [ H : context[free_vars (mk_union     _ _)] |- _ ] => rewrite free_vars_union in H
    | [ H : context[free_vars (mk_bunion    _ _)] |- _ ] => rewrite free_vars_bunion in H
    | [ H : context[free_vars (mk_uand      _ _)] |- _ ] => rewrite free_vars_uand in H
    | [ H : context[free_vars (mk_apply     _ _)] |- _ ] => rewrite free_vars_apply in H
    | [ H : context[free_vars (mk_tequality _ _)] |- _ ] => rewrite free_vars_tequality in H
    | [ H : context[free_vars (mk_approx    _ _)] |- _ ] => rewrite free_vars_approx in H

    | [ H : context[free_vars mk_axiom] |- _ ] => rewrite free_vars_axiom in H
    | [ H : context[free_vars mk_base]  |- _ ] => rewrite free_vars_base in H
    | [ H : context[free_vars mk_bool]  |- _ ] => rewrite free_vars_bool in H
    | [ H : context[free_vars mk_unit]  |- _ ] => rewrite free_vars_unit in H
  end.

Ltac insub_step :=
  match goal with
    | [ H : similarity _ _ _ _ |- _ ] => apply similarity_dom in H; repnd
    | [ H : eq_hyps _ _ _ _ |- _ ] => apply eq_hyps_dom in H; repnd
    | [ H : sub_eq_hyps _ _ _ _ _ _ |- _ ] => apply sub_eq_hyps_dom in H; repnd
    | [ |- context[dom_csub (snoc _ _)] ] => rewrite dom_csub_snoc
    | [ |- context[LIn _ (snoc _ _)] ] => trw in_snoc
    | [ |- context[_ ++ nil] ] => rewrite app_nil_r
    | [ |- context[dom_csub (snoc _ _)] ] => rewrite dom_csub_snoc
    | [ |- context[LIn _ (_ :: nil)] ] => trw in_single_iff
    | [ |- context[LIn _ (snoc _ _)] ] => trw in_snoc
    | [ |- context[LIn _ (app _ _)] ] => trw in_app_iff
    | [ |- context[LIn _ (remove_nvars _ _)] ] => trw in_remove_nvars
    | [ |- context[!(_ [+] _)] ] => trw not_over_or
    | [ |- context[vars_hyps (substitute_hyps _ _)] ] => rewrite vars_hyps_substitute_hyps
    | [ |- context[disjoint [_] _] ] => trw disjoint_singleton_l
    | [ H : vars_hyps _ = dom_csub ?s |- context[dom_csub ?s] ] => rewrite <- H
    | [ H : dom_csub ?s = vars_hyps _ |- context[dom_csub ?s] ] => rewrite H
    | [ H : vars_hyps _ = dom_csub ?s, H2 : context[dom_csub ?s] |- _ ] => rewrite <- H in H2
    | [ H : dom_csub ?s = vars_hyps _, H2 : context[dom_csub ?s] |- _ ] => rewrite H in H2
  end.

Ltac ainsub := repeat (first [ free_vars_rw | simpl; insub_step; simpl ]; auto).
Ltac insub := ainsub; sp.

Ltac splst_step :=
  match goal with
    | [ |- context[LIn _ (_ :: nil)] ] => trw in_single_iff
    | [ |- context[LIn _ (snoc _ _)] ] => trw in_snoc
    | [ |- context[LIn _ (app _ _)] ] => trw in_app_iff
    | [ |- context[LIn _ (remove_nvars _ _)] ] => trw in_remove_nvars
    | [ |- context[dom_csub (snoc _ _)] ] => rewrite dom_csub_snoc
    | [ |- context[dom_csub (csub_filter _ _)] ] => rewrite dom_csub_csub_filter
    | [ |- context[dom_sub (snoc _ _)] ] => rewrite dom_sub_snoc
    | [ |- context[dom_sub (csub2sub _)] ] => rewrite dom_csub_eq
    | [ |- context[!(_ [+] _)] ] => trw not_over_or
  end.

Ltac splst_step_hyp h :=
  match type of h with
    | context[LIn _ (_ :: nil)] => trw_h in_single_iff h
    | context[LIn _ (snoc _ _)] => trw_h in_snoc h
    | context[LIn _ (app _ _)] => trw_h in_app_iff h
    | context[LIn _ (remove_nvars _ _)] => trw_h in_remove_nvars h
    | context[dom_csub (snoc _ _)] => rewrite dom_csub_snoc in h
    | context[dom_csub (csub_filter _ _)] => rewrite dom_csub_csub_filter in h
    | context[dom_sub (snoc _ _)] => rewrite dom_sub_snoc in h
    | context[dom_sub (csub2sub _)] => rewrite dom_csub_eq in h
    | context[!(_ [+] _)] => trw_h not_over_or h
  end.

Tactic Notation "splst" := repeat (splst_step; simpl).
Tactic Notation "splst" "in" ident(h) := repeat (splst_step_hyp h; simpl in h).

Ltac rwall eq :=
  match type of eq with
    | ?x = ?y =>
      repeat match goal with
               | [ eq : x = y |- context[x] ] => rewrite eq
               | [ eq : x = y, H : context[x] |- _ ] => rewrite eq in H
             end
  end.

Lemma test_rwall :
  forall x y,
    x = 1
    -> x = y
    -> x = y
    -> y = x
    -> False.
Proof.
  introv e1 e2 e3 e4.
  rwall e3.
Abort.

Tactic Notation "lsubstc_snoc_step" constr(T) tactic(tac) :=
  match T with
    (*
     * ==== 1 ====
     * lsubstc t (snoc s (x,u)) = lsubstc t s
     * if x not in the free variables of t
     *)
    | context[lsubstc ?t ?w (snoc ?s (?x, ?u)) ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : !LIn x (free_vars t) |- _ ] =>
          pose proof (subset_free_vars_lsubstc_snoc_ex t s x u w c H) neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (!LIn x (free_vars t)) as H by tac;
            pose proof (subset_free_vars_lsubstc_snoc_ex t s x u w c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 2 ====
     * lsubstc t ((x,u) :: s) = lsubstc t s
     * if x not in the free variables of t
     *)
    | context[lsubstc ?t ?w ((?x, ?u) :: ?s) ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : !LIn x (free_vars t) |- _ ] =>
          pose proof (subset_free_vars_lsubstc_cons_ex t s x u w c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (!LIn x (free_vars t)) as H by tac;
            pose proof (subset_free_vars_lsubstc_cons_ex t s x u w c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 3 ====
     * lsubstc (mk_var x) (snoc s (y,t)) = lsubstc (mk_var x) s
     * if x in s
     *)
    | context[lsubstc (mk_var ?x) ?w (snoc ?s (?y, ?t)) ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : LIn x (dom_csub s) |- _ ] =>
          pose proof (lsubstc_snoc_var2_ex x s y t w c H) as neq;
            destruct neq as [ nc neq ];
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (LIn x (dom_csub s)) as H by tac;
            pose proof (lsubstc_snoc_var2_ex x s y t w c H) as neq;
            destruct neq as [ nc neq ];
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 4 ====
     * lsubstc (mk_var x) (snoc s (x,t)) = t
     * if x not in s
     *)
    | context[lsubstc (mk_var ?x) ?w (snoc ?s (?x, ?t)) ?c] =>
      let neq := fresh "eq" in
      match goal with
        | [ H : !LIn x (dom_csub s) |- _ ] =>
          pose proof (lsubstc_snoc_var s x t w c H) as neq;
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (!LIn x (dom_csub s)) as H by tac;
            pose proof (lsubstc_snoc_var s x t w c H) as neq;
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 5 ====
     * lsubstc (mk_var x) ((y,t) :: s) = lsubstc (mk_var x) s
     * if x <> y
     *)
    | context[lsubstc (mk_var ?x) ?w ((?y, ?t) :: ?s) ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : x <> y |- _ ] =>
          pose proof (lsubstc_cons_var2_ex x s y t w c H) as neq;
            destruct neq as [ nc neq ];
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (x <> y) as H by tac;
            pose proof (lsubstc_cons_var2_ex x s y t w c H) as neq;
            destruct neq as [ nc neq ];
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 6 ====
     * lsubstc (mk_var x) ((x,t) :: s) = t
     *)
    | context[lsubstc (mk_var ?x) ?w ((?x, ?t) :: ?s) ?c] =>
      let neq := fresh "eq" in
      pose proof (lsubstc_cons_var s x t w c) as neq;
        rwall neq;
        clear neq

    (*
     * ==== 7 ====
     * lsubstc t p (sub1 ++ sub2) c = lsubstc t p sub1 c'
     * if disjoint (Free_vars t) (dom_csub sub2)
     *)
    | context[lsubstc ?t ?w (app ?s1 ?s2) ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : disjoint (free_vars t) (dom_csub s2) |- _ ] =>
          pose proof (subset_free_vars_lsubstc_app_ex t s1 s2 w c H) as neq;
            destruct neq as [ nc neq ];
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "disj" in
          assert (disjoint (free_vars t) (dom_csub s2)) as H by tac;
            pose proof (subset_free_vars_lsubstc_app_ex t s1 s2 w c H) as neq;
            destruct neq as [ nc neq ];
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 8 ====
     * csubst t (snoc s (x,u)) = csubst t s
     * if x not in the free variables of t
     *)
    | context[csubst ?t (snoc ?s (?x, ?u))] =>
      let neq := fresh "eq" in
      match goal with
        | [ H : !LIn x (free_vars t) |- _ ] =>
          pose proof (subset_free_vars_csub_snoc t s x u H) as neq;
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (!LIn x (free_vars t)) as H by tac;
            pose proof (subset_free_vars_csub_snoc t s x u H) as neq;
            rwall neq;
            clear neq;
            clear H
      end
end.

Tactic Notation "lsubstc_snoc_step_vs" constr(T) tactic(tac) :=
  match T with
    (*
     * ==== 9 ====
     * lsubstc_vars t w (snoc s (x,u)) vs c = lsubstc_vars t w s vs c'
     * if x not in the free variables of t
     *)
    | context[lsubstc_vars ?t ?w (snoc ?s (?x, ?u)) ?vs ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : !LIn x (free_vars t) |- _ ] =>
          pose proof (subset_free_vars_lsubstc_vars_snoc_ex t s x u w vs c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (!LIn x (free_vars t)) as H by tac;
            pose proof (subset_free_vars_lsubstc_vars_snoc_ex t s x u w vs c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq;
            clear H
      end

    (*
     * ==== 10 ====
     * lsubstc_vars t w (csub_filter (snoc s (x,u)) vs) vs c
     *   = lsubstc_vars t w (csub_filter s vs) vs c'
     * if x not in the free variables of t
     *)
    | context[lsubstc_vars ?t ?w (csub_filter (snoc ?s (?x, ?u)) ?vs) ?vs ?c] =>
      let neq := fresh "eq" in
      let nc := fresh "c" in
      match goal with
        | [ H : !LIn x vs -> !LIn x (free_vars t) |- _ ] =>
          pose proof (lsubstc_vars_csub_filter_snoc_ex t w s x u vs c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq
        | _ =>
          let H := fresh "lin" in
          assert (!LIn x vs -> !LIn x (free_vars t)) as H by (first [splst; sp | tac]);
            pose proof (lsubstc_vars_csub_filter_snoc_ex t w s x u vs c H) as neq;
            destruct neq as [ nc neq ];
            clear_irr;
            rwall neq;
            clear neq;
            clear H
      end
  end.

Tactic Notation "lsubstc_snoc_step_hyp" ident(H) tactic(tac) :=
  let T := type of H in
  progress (lsubstc_snoc_step T tac).

Tactic Notation "lsubstc_snoc_step_concl" tactic(tac) :=
  match goal with
  | [ |- ?T ] => progress (lsubstc_snoc_step T tac)
  end.

Tactic Notation "lsubstc_snoc_step_all" tactic(tac) :=
  match goal with
  | [ |- ?T ] => progress (lsubstc_snoc_step T tac)
  | [ H : ?T |- _ ] => progress (lsubstc_snoc_step T tac)
  end.

Tactic Notation "lsubstc_snoc_step_vs_hyp" ident(H) tactic(tac) :=
  let T := type of H in
  progress (lsubstc_snoc_step_vs T tac).

Tactic Notation "lsubstc_snoc_step_vs_concl" tactic(tac) :=
  match goal with
  | [ |- ?T ] => progress (lsubstc_snoc_step_vs T tac)
  end.

Tactic Notation "lsubstc_snoc_step_vs_all" tactic(tac) :=
  match goal with
  | [ |- ?T ] => progress (lsubstc_snoc_step_vs T tac)
  | [ H : ?T |- _ ] => progress (lsubstc_snoc_step_vs T tac)
  end.

Ltac lsubstc_snoc := repeat (lsubstc_snoc_step_all insub).
Ltac lsubstc_snoc_concl := repeat (lsubstc_snoc_step_concl insub).
Ltac lsubstc_snoc_hyp H := repeat (lsubstc_snoc_step_hyp H insub).
Ltac lsubstc_snoc_vs := repeat (lsubstc_snoc_step_vs_all insub).

Ltac ai_lsubstc_snoc := repeat (lsubstc_snoc_step_all ainsub).
Ltac ai_lsubstc_snoc_vs := repeat (lsubstc_snoc_step_vs_all ainsub).

Ltac a_lsubstc_snoc := repeat (lsubstc_snoc_step_all auto).
Ltac a_lsubstc_snoc_vs := repeat (lsubstc_snoc_step_vs_all auto).

Ltac lsubst_tac :=
  lift_lsubsts;
  lsubstc_snoc;
  lift_lsubsts.

(* !! Make a hyp version of lsubstc_snoc *)
Ltac lsubst_tac_h H :=
  lift_lsubst_hyp H;
  lsubstc_snoc;
  lift_lsubst_hyp H.

Ltac a_lsubst_tac :=
  lift_lsubsts;
  a_lsubstc_snoc;
  lift_lsubsts.

Ltac ai_lsubst_tac :=
  lift_lsubsts;
  ai_lsubstc_snoc;
  lift_lsubsts.

Ltac simplerw :=
  allrw @wf_equality_iff2;    exrepd; allsimpl;
  allrw @covered_equality;    exrepd; allsimpl;
  allrw @vars_hyps_app;       exrepd; allsimpl;
  allrw @vars_hyps_snoc;      exrepd; allsimpl;
  allrw @nh_vars_hyps_app;    exrepd; allsimpl;
  allrw @nh_vars_hyps_snoc;   exrepd; allsimpl;
  allrw @subvars_singleton_l; exrepd; allsimpl;
  allrw @in_app_iff;          exrepd; allsimpl;
  allrw @in_snoc;             exrepd; allsimpl;
  try (complete sp).

Ltac prove_seq :=
  allunfold args_constraints;
  allunfold arg_constraints;
  allunfold wf_csequent;
  allunfold closed_type_baresequent;
  allunfold closed_extract_baresequent;
  allunfold closed_type;
  allunfold closed_extract;
  allunfold wf_sequent;
  allunfold wf_concl;
  allsimpl; sp; subst; allsimpl; sp;
  simplerw.

(* This is meant to replace prove_seq *)
Ltac wfseq :=
  repeat (first [ progress sp
                | progress subst
                | progress allsimpl
                | progress simplerw
                | progress (allunfold @args_constraints); allsimpl
                | progress (allunfold @arg_constraints); allsimpl
                | progress (allunfold @wf_csequent); allsimpl
                | progress (allunfold @closed_type_baresequent); allsimpl
                | progress (allunfold @closed_extract_baresequent); allsimpl
                | progress (allunfold @closed_type); allsimpl
                | progress (allunfold @closed_extract); allsimpl
                | progress (allunfold @wf_sequent); allsimpl
                | progress (allunfold @wf_concl); allsimpl
                | progress (rw @covered_isect); allsimpl
                | progress (rw @covered_cequiv); allsimpl
                | progress (rw @covered_approx); allsimpl
                | progress (rw @covered_equality); allsimpl
                | progress (rw @covered_var); allsimpl
         ]).

(* This is meant to replace wfseq and prove_seq *)
Ltac dwfseq_step :=
  match goal with
    (* unfold in hyp *)
    | [ H : wf_csequent _ |- _ ] => unfold wf_csequent in H; repnd; allsimpl
    | [ H : wf_sequent _ |- _ ] => unfold wf_sequent in H; repnd; allsimpl
    | [ H : wf_concl _ |- _ ] => unfold wf_concl in H; repnd; allsimpl
    | [ H : closed_type _ _ |- _ ] => unfold closed_type in H; repnd; allsimpl
    | [ H : closed_extract _ _ |- _ ] => unfold closed_extract in H; repnd; allsimpl
    | [ H : closed_type_baresequent _ |- _ ] => unfold closed_type_baresequent in H; repnd; allsimpl
    | [ H : closed_extract_baresequent _ |- _ ] => unfold closed_extract_baresequent in H; repnd; allsimpl
    | [ H : covered _ _ |- _ ] => unfold covered in H; repnd; allsimpl
    | [ H : args_constraints _ _ |- _ ] => unfold args_constraints in H; repnd; allsimpl
    | [ H : arg_constraints _ _ |- _ ] => unfold arg_constraints in H; repnd; allsimpl
    (* unfold in concl *)
    | [ |- context[covered _ _] ] => unfold covered; allsimpl
    (* rewrite in context in hyps *)
    | [ H : context[hyps_free_vars (_ ++ _)] |- _ ] => rewrite hyps_free_vars_app in H
    | [ H : context[hyps_free_vars (snoc _ _)] |- _ ] => rewrite hyps_free_vars_snoc in H
    | [ H : context[app _ nil] |- _ ] => rewrite app_nil_r in H; repnd; allsimpl
    | [ H : context[remove_nvars [] _] |- _ ] => rewrite remove_nvars_nil_l in H; repnd; allsimpl
    | [ H : context[vars_hyps (app _ _)] |- _ ] => rewrite vars_hyps_app in H; allsimpl
    | [ H : context[vars_hyps (snoc _ _)] |- _ ] => rewrite vars_hyps_snoc in H; allsimpl
    | [ H : context[nh_vars_hyps (app _ _)] |- _ ] => rewrite nh_vars_hyps_app in H; repnd; allsimpl
    | [ H : context[nh_vars_hyps (snoc _ _)] |- _ ] => rewrite nh_vars_hyps_snoc in H; repnd; allsimpl
    | [ H : context[hyp_free_vars (mk_hyp _ _)] |- _ ] => rewrite hyp_free_vars_mk_hyp in H; repnd; allsimpl
    | [ H : context[hyp_free_vars (mk_hhyp _ _)] |- _ ] => rewrite hyp_free_vars_mk_hhyp in H; repnd; allsimpl
    | [ H : context[filter _ (app _ _)] |- _ ] => rewrite filter_app in H; repnd; allsimpl
    | [ H : context[filter _ (snoc _ _)] |- _ ] => rewrite filter_snoc in H; repnd; allsimpl
    (* rewrite in context in concl *)
    | [ |- context[hyps_free_vars (_ ++ _)] ] => rewrite hyps_free_vars_app
    | [ |- context[hyps_free_vars (snoc _ _)] ] => rewrite hyps_free_vars_snoc
    | [ |- context[app _ nil] ] => rewrite app_nil_r; repnd; allsimpl
    | [ |- context[remove_nvars [] _] ] => rewrite remove_nvars_nil_l; repnd; allsimpl
    | [ |- context[vars_hyps (app _ _)] ] => rewrite vars_hyps_app; allsimpl
    | [ |- context[vars_hyps (snoc _ _)] ] => rewrite vars_hyps_snoc; allsimpl
    | [ |- context[nh_vars_hyps (app _ _)] ] => rewrite nh_vars_hyps_app; repnd; allsimpl
    | [ |- context[nh_vars_hyps (snoc _ _)] ] => rewrite nh_vars_hyps_snoc; repnd; allsimpl
    | [ |- context[hyp_free_vars (mk_hyp _ _)] ] => rewrite hyp_free_vars_mk_hyp; repnd; allsimpl
    | [ |- context[hyp_free_vars (mk_hhyp _ _)] ] => rewrite hyp_free_vars_mk_hhyp; repnd; allsimpl
    | [ |- context[filter _ (app _ _)] ] => rewrite filter_app; repnd; allsimpl
    | [ |- context[filter _ (snoc _ _)] ] => rewrite filter_snoc; repnd; allsimpl
    (* trw_h in context in hyps *)
    | [ H : context [LIn _ (snoc _ _)] |- _ ] => trw_h in_snoc H; repnd; allsimpl
    | [ H : context [LIn _ (app _ _)] |- _ ] => trw_h in_app_iff H; repnd; allsimpl
    (* trw_h in context in concl *)
    | [ |- context [LIn _ (snoc _ _)] ] => trw in_snoc; repnd; allsimpl
    | [ |- context [LIn _ (app _ _)] ] => trw in_app_iff; repnd; allsimpl
    (* trw_h *)
    | [ H : vs_wf_hypotheses _ (app _ _) |- _ ] => trw_h vs_wf_hypotheses_app H; repnd; allsimpl
    | [ H : vs_wf_hypotheses _ (snoc _ _) |- _ ] => trw_h vs_wf_hypotheses_snoc H; repnd; allsimpl
    | [ H : wf_hypotheses (app _ _) |- _ ] => trw_h wf_hypotheses_app H; repnd; allsimpl
    | [ H : wf_hypotheses (snoc _ _) |- _ ] => trw_h wf_hypotheses_snoc H; repnd; allsimpl
    | [ H : isprog_vars _ _ |- _ ] => trw_h isprog_vars_eq H; repnd; allsimpl
    | [ H : disjoint (snoc _ _) _ |- _ ] => trw_h disjoint_snoc_l H; repnd; allsimpl
    | [ H : disjoint _ (snoc _ _) |- _ ] => trw_h disjoint_snoc_r H; repnd; allsimpl
    | [ H : subvars nil _ |- _ ] => trw_h subvars_nil_l_iff H
    | [ H : subvars (app _ _) _ |- _ ] => trw_h subvars_app_l H; repnd; allsimpl
    | [ H : subvars (cons _ _) _ |- _ ] => trw_h subvars_cons_l H; repnd; allsimpl
    | [ H : subvars _ _ |- _ ] => trw_h subvars_prop H; repnd; allsimpl
    | [ H : nt_wf _ |- _ ] => trw_h nt_wf_eq H; repnd; allsimpl
    (* trw *)
    | [ |- context[subvars _ _] ] => trw subvars_prop; allsimpl
    (* apply *)
    | [ H : vs_wf_hypotheses _ _ |- _ ] => apply vs_wf_hypotheses_implies in H; repnd
    | [ H : vswf_hypotheses _ _ |- _ ] => apply vswf_hypotheses_nil_implies in H; repnd
    | [ H : ~ (_ \/ _) |- _ ] => apply not_or in H; repnd
    | [ H : !(_ [+] _) |- _ ] => apply not_over_or in H; repnd
  end; GC.

Ltac dwfseq := repeat dwfseq_step.

Tactic Notation "vr_seq_true" :=
  rw @sequent_true_eq_VR;
  rw @VR_sequent_true_all;
  simpl;
  introv sim eqh;
  introv;
  proof_irr;
  GC.

 Ltac vr_seq_true_ltac H :=
  trw_h sequent_true_eq_VR  H;
  trw_h VR_sequent_true_ex  H;
  simpl in H.

Tactic Notation "vr_seq_true" "in" ident(H) :=
  vr_seq_true_ltac H.

Ltac subst_app_step :=
  match goal with
    | [ |- context[lsubstc ?t ?w (?s1 ++ ?s2) ?c] ] =>
        let w' := fresh "w'" in
        let c' := fresh "c'" in
        let h  := fresh "h"  in
          generalize (lsubstc_csubst_ex2 t s1 s2 w c);
        intro h;
        destruct h as [w' h];
        destruct h as [c' h];
        rewrite <- h;
        clear h;
        proof_irr

    | [ H : context[lsubstc ?t ?w (?s1 ++ ?s2) ?c] |- _ ] =>
        let w' := fresh "w'" in
        let c' := fresh "c'" in
        let h  := fresh "h"  in
          generalize (lsubstc_csubst_ex2 t s1 s2 w c);
        intro h;
        destruct h as [w' h];
        destruct h as [c' h];
        rewrite <- h in H;
        clear h;
        proof_irr;
        GC
  end.

Ltac subst_app := repeat subst_app_step.


Require Import VST.floyd.proofauto.
Require Import qsort3.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Require Import float_lemmas.
Require Import Permutation.

Definition quicksort_spec :=
 DECLARE _quicksort
  WITH base: val, N: Z, al: list val
  PRE  [ tptr tdouble, tint]
    PROP(N=Zlength al; N <=Z.min Int.max_signed (Ptrofs.max_signed / sizeof tdouble); Forall def_float al)
    PARAMS(base; Vint (Int.repr N)) GLOBALS ()
    SEP(data_at Ews (tarray tdouble N) al base)
  POST [ tvoid ]
    EX bl: list val,
     PROP(Permutation al bl; sorted (f_cmp Cle) bl)
     LOCAL ()
    SEP(data_at Ews (tarray tdouble N) bl base).

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr 0)))
     SEP(TT).

Definition Gprog : funspecs :=
        ltac:(with_library prog [quicksort_spec]).


(* Copyright  2008-2008
 * Cezary Kaliszyk
 * Russell O'Connor
 *
 * This work 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 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

(**
** Decidability of connectives
Here we show the decidability of logical connectives.
*)

Lemma imp_dec : (forall A B, ({A} + {~A}) -> ({B} + {~B}) -> ({A -> B} + {~(A -> B)})).
Proof.
 tauto.
Qed.

(* TODO: other connectives *)


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cartesian.
Require Export Category.Structure.Cocartesian.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Bicartesian.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Cocartesian C}.

Corollary fork_merge {x y z w : C}
(f : x ~> y) (g : x ~> z) (h : w ~> y) (i : w ~> z) :
(f △ g) ▽ (h △ i) ≈ (f ▽ h) △ (g ▽ i).
Proof. hammer_hook "Bicartesian" "Bicartesian.fork_merge".
rewrite <- id_left.
rewrite <- fork_exl_exr.
rewrite <- fork_comp.
apply fork_respects;
rewrite <- merge_comp; cat;
apply (@fork_respects (C^op)); cat.
Qed.

End Bicartesian.


(* monae: Monadic equational reasoning in Coq                                 *)
(* Copyright (C) 2020 monae authors, license: LGPL-2.1-or-later               *)
Require Import Eqdep JMeq List ssreflect.
Import ListNotations.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import hierarchy monad_lib state_lib trace_lib monad_model.

(******************************************************************************)
(*              Application of monadTrace to program semantics                *)
(*                                                                            *)
(* Inductive program, Inductive continuation:                                 *)
(*   Syntax for an imperative language with a primitive to record execution   *)
(*   trace                                                                    *)
(* Section OperationalSemantics, Inductive step:                              *)
(*   A small-step semantics                                                   *)
(* DenotationalSemantics:                                                     *)
(*   Denotation given in terms of the state/trace monad                       *)
(* Section semantics_equivalence:                                             *)
(*.  Prove that the small-step semantics is equivalent to the denotation      *)
(* nonce, nonce_twice, countdown, etc.                                        *)
(*   Examples of programs using traces and their small-step and denotational  *)
(* semantics.                                                                 *)
(*                                                                            *)
(* reference:                                                                 *)
(* - R. Affeldt, D. Nowak, T. Saikawa, A Hierarchy of Monadic Effects for     *)
(* Program Verification using Equational Reasoning, MPC 2019                  *)
(******************************************************************************)

Set Universe Polymorphism.
Unset Universe Minimization ToSet.
Set Polymorphic Inductive Cumulativity.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Bullet Behavior "Strict Subproofs".

Obligation Tactic := idtac.

Reserved Notation "'p_do' x <- m ; e"
  (at level 60, x name, m at level 200, e at level 60).
Reserved Notation "'p_do' x : T <- m ; e"
  (at level 60, x name, m at level 200, e at level 60).

Section Syntax.

Variables T S : Type.

Inductive program : Type -> Type :=
| p_ret  : forall {A}, A -> program A
| p_bind : forall {A B}, program A -> (A -> program B) -> program B
| p_cond : forall {A}, bool -> program A -> program A -> program A
| p_repeat : nat -> program unit -> program unit
| p_while : nat -> (S -> bool) -> program unit -> program unit
| p_get  : program S
| p_put  : S -> program unit
| p_mark : T -> program unit.

Local Notation "'p_do' x <- m ; e" := (p_bind m (fun x => e)).
Local Notation "'p_do' x : T <- m ; e" :=(p_bind m (fun x : T => e)).

Inductive continuation : Type :=
| stop : forall A, A -> continuation
| cont : forall A, program A -> (A -> continuation) -> continuation.

End Syntax.

Arguments program {_ _} _.
Arguments p_ret {_ _ _} _.
Arguments p_bind {_ _ _ _} _ _.
Arguments p_cond {_ _ _} _ _ _.
Arguments p_repeat {_ _} _ _.
Arguments p_while {_ _} _ _ _.
Arguments p_get {_ _}.
Arguments p_put {_ _} _.
Arguments p_mark {_ _} _.
Arguments continuation {_ _}.
Arguments stop {_ _} _ _.
Arguments cont {_ _} _ _ _.

Notation "'p_do' x <- m ; e" := (@p_bind _ _ _ _ m (fun x => e)).
Notation "'p_do' x : T <- m ; e" := (@p_bind _ _ _ _ m (fun x : T => e)).

Notation "p `; k" := (@cont _ _ _ p k) (at level 50).

Section OperationalSemantics.

Variables T S : Type.

Definition state : Type := S * @continuation T S.

Inductive step : state -> option T -> state -> Prop :=
| s_ret  : forall s A a (k : A -> _), step (s, p_ret a `; k) None (s, k a)
| s_bind : forall s A B p (f : A -> program B) k,
  step (s, p_bind p f `; k) None (s, p `; fun a => f a `; k)
| s_cond_true : forall s A p1 p2 (k : A -> _),
  step (s, p_cond true p1 p2 `; k) None (s, p1 `; k)
| s_cond_false : forall s A p1 p2 (k : A -> _),
  step (s, p_cond false p1 p2 `; k) None (s, p2 `; k)
| s_repeat_O : forall s p k, step (s, p_repeat O p `; k) None (s, k tt)
| s_repeat_S : forall s n p k,
  step (s, p_repeat n.+1 p `; k) None
    (s, p `; fun _ => p_repeat n p `; k)
| s_while_true : forall fuel s c p k, c s = true ->
  step (s, p_while fuel.+1 c p `; k) None
    (s, p `; fun _ => p_while fuel c p `; k)
| s_while_false : forall fuel s c p k, c s = false ->
  step (s, p_while fuel.+1 c p `; k) None (s, k tt)
| s_while_broke : forall s c p k, step (s, p_while O c p `; k) None (s, k tt)
| s_get  : forall s k, step (s, p_get `; k) None (s, k s)
| s_put  : forall s s' k, step (s, p_put s' `; k) None (s', k tt)
| s_mark : forall s t k, step (s, p_mark t `; k) (Some t) (s, k tt).

Inductive step_n : nat -> state -> list T -> state -> Prop :=
| sn_0 : forall sk, step_n O sk [] sk
| sn_S_None : forall n sk1 sk2 sk3 l,
  step sk1 None sk2 -> step_n n sk2 l sk3 ->
  step_n n.+1 sk1 l sk3
| sn_S_Some : forall n sk1 sk2 sk3 t l,
  step sk1 (Some t) sk2 -> step_n n sk2 l sk3 ->
  step_n n.+1 sk1 (t :: l) sk3.

Inductive step_star : state -> list T -> state -> Prop :=
| ss_refl : forall sk, step_star sk [] sk
| ss_step_None : forall sk1 sk2 sk3 l,
  step sk1 None sk2 -> step_star sk2 l sk3 -> step_star sk1 l sk3
| ss_step_Some : forall sk1 sk2 sk3 t l,
  step sk1 (Some t) sk2 -> step_star sk2 l sk3 -> step_star sk1 (t :: l) sk3.

Lemma step_star_transitive sk1 sk2 sk3 l l' :
  step_star sk1 l sk2 -> step_star sk2 l' sk3 -> step_star sk1 (l ++ l') sk3.
Proof.
intro Hss1.
revert sk3 l'.
induction Hss1 as
 [ | sk1 sk2 sk3 l Hstep Hss1 IH | sk1 sk2 sk3 t l Hstep Hss1 IH ];
 intros sk3' l' Hss2; [ assumption | | ].
- apply ss_step_None with (sk2 := sk2).
  + exact Hstep.
  + apply IH; exact Hss2.
- apply ss_step_Some with (sk2 := sk2).
  + exact Hstep.
  + apply IH; exact Hss2.
Qed.

Lemma step_star_stop_inv s A a l sk :
  step_star (s, stop A a) l sk -> l = [] /\ sk = (s, stop A a).
Proof.
intro Hss.
inversion Hss.
- split; reflexivity.
- subst.
  match goal with H : step _ _ _ |- _ => inversion H end.
- subst.
  match goal with H : step _ _ _ |- _ => inversion H end.
Qed.

Lemma step_deterministic ski l1 l2 sk1 sk2 :
  step ski l1 sk1 -> step ski l2 sk2 -> l1 = l2 /\ sk1 = sk2.
Proof.
intro Hstep1.
revert l2 sk2.
induction Hstep1; intros l2 sk2 Hstep2;
match goal with
| _ : step (?s, ?k) _ _ |- _ => remember (s, k) as sk1 eqn: Heq2
end; inversion Hstep2; clear Hstep2; subst; try discriminate;
match goal with
| H : _ = _ |- _ => injection H; clear H; intros
end; subst;
repeat match goal with
| H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H
end; subst; repeat split; congruence.
Qed.

Lemma step_star_confluent ski sk1 sk2 l1 l2 :
  step_star ski l1 sk1 -> step_star ski l2 sk2 ->
  exists l1' l2' skf,
  step_star sk1 l1' skf /\ step_star sk2 l2' skf /\ l1 ++ l1' = l2 ++ l2'.
Proof.
intro Hss1.
revert l2 sk2.
induction Hss1 as [
    s
  | sk1 sk2' sk3 l1 Hstep1 Hss1 IH
  | sk1 sk2' sk3 t1 l1 Hstep1 Hss1 IH
  ].
- intros l2 sk2 Hss2.
  exists l2. exists []. exists sk2.
  split; [ | split ].
  + exact Hss2.
  + apply ss_refl.
  + rewrite cats0; reflexivity.
- intros l2 sk2 Hss2.
  inversion Hss2 as [
    sk1' Hsk1 Hl2 Hsk2
  | sk1' sk2'' sk2''' l2' Hstep2 Hss2' Hsk1 Hl2 Hsl2
  | sk1' sk2'' sk2''' t2 l2' Hstep2 Hss2' Hsk1 Hl2 Hsl2
  ].
  + subst sk1' l2 sk2.
    do 3 eexists.
    split; [ apply ss_refl | ].
    split; [ eapply ss_step_None; eassumption | ].
    rewrite cats0; reflexivity.
  + subst sk1' l2' sk2'''.
    specialize (step_deterministic Hstep1 Hstep2).
    intros [ [] Heq2].
    subst sk2''.
    apply IH.
    exact Hss2'.
  + subst sk1' l2 sk2'''.
    specialize (step_deterministic Hstep1 Hstep2).
    intros [ [=] ?].
- intros l2 sk2 Hss2.
  inversion Hss2 as [
    sk1' Hsk1 Hl2 Hsk2
  | sk1' sk2'' sk2''' l2' Hstep2 Hss2' Hsk1 Hl2 Hsl2
  | sk1' sk2'' sk2''' t2 l2' Hstep2 Hss2' Hsk1 Hl2 Hsl2
  ].
  + subst sk1' l2 sk2.
    do 3 eexists.
    split; [ apply ss_refl | ].
    split; [ eapply ss_step_Some; eassumption | ].
    rewrite cats0; reflexivity.
  + subst sk1' l2' sk2'''.
    specialize (step_deterministic Hstep1 Hstep2).
    intros [ [=] ?].
  + subst sk1' l2 sk2'''.
    specialize (step_deterministic Hstep1 Hstep2).
    intros [ [= Heq1] Heq2].
    subst t2 sk2''.
    apply IH in Hss2'.
    destruct Hss2' as (l1' & l2'' & skf & Hss3 & Hss4 & Heq).
    do 3 eexists.
    do 2 (split; [ eassumption | ]).
    cbn.
    f_equal.
    exact Heq.
Qed.

Lemma step_star_deterministic ski l1 l2 s1 s2 A1 A2 a1 a2 :
  step_star ski l1 (s1, stop A1 a1) -> step_star ski l2 (s2, stop A2 a2) ->
  l1 = l2 /\ s1 = s2 /\ A1 = A2 /\ JMeq a1 a2.
Proof.
intros Hss1 Hss2.
specialize (step_star_confluent Hss1 Hss2).
intros (l1' & l2' & skf & Hss1' & Hss2' & Heq).
apply step_star_stop_inv in Hss1'.
apply step_star_stop_inv in Hss2'.
destruct Hss1' as [ Heq11 Heq12 ].
destruct Hss2' as [ Heq21 Heq22 ].
subst l1' l2' skf .
do 2 rewrite cats0 in Heq.
injection Heq22; clear Heq22; intros; subst.
match goal with
| H : existT _ _ _ = existT _ _ _ |- _ => apply inj_pair2 in H
end.
subst.
repeat split.
Qed.

Definition run_s {A : Type} (p : program A) (f : A -> continuation) (s : S) :
  {o & {f' & {s' | step (s, p `; f) o (s', f') } } }.
Proof.
destruct p as [ A a | A B p g | A b p1 p2 | n p | fuel c p | | s' | t ];
 try (repeat eexists; constructor).
- destruct b; repeat eexists; constructor.
- destruct n; repeat eexists; constructor.
- destruct fuel.
  + repeat eexists; constructor.
  + case_eq (c s); intro Hcs; repeat eexists.
    * apply s_while_true.
      exact Hcs.
    * apply s_while_false.
      exact Hcs.
Defined.

Definition run_s_n (n : nat)
  {A : Type} (p : program A) (f : A -> continuation) (s : S) :
  option {l & {f' & {s' | step_n n (s, p `; f) l (s', f') } } }.
Proof.
revert n A p f s.
fix run_s_n 1.
intros [ | n' ] A p f s.
- apply Some.
  exists []. exists (cont A p f). exists s.
  apply sn_0.
- destruct (run_s p f s) as (o & [ B b | B p' f' ] & s' & Hstep).
  + destruct n' as [ | n'' ].
    * apply Some.
      destruct o as [ t | ]; repeat eexists.
      -- eapply sn_S_Some.
         ++ exact Hstep.
         ++ apply sn_0.
      -- eapply sn_S_None.
         ++ exact Hstep.
         ++ apply sn_0.
    * apply None.
  + destruct (run_s_n n' B p' f' s') as [ (l & f'' & s'' & Hstep_n') | ].
    * apply Some.
      destruct o as [ t | ]; repeat eexists.
      -- eapply sn_S_Some.
         ++ exact Hstep.
         ++ exact Hstep_n'.
      -- eapply sn_S_None.
         ++ exact Hstep.
         ++ exact Hstep_n'.
    * exact None.
Defined.

Definition run_gen
  {A : Type} (p : program A) (f : A -> continuation) (s : S) :
  {l & {a : A & {s' | step_star (s, p `; f) l (s', f a) } } }.
Proof.
revert f s.
induction p as [ A a | A B p IHp g IHg | A b p1 IHp1 p2 IHp2 |
  n p IHp | fuel c p IHp | | s' | t ];
 intros f s.
- exists []. exists a. exists s.
  abstract (eapply ss_step_None; [ apply s_ret | apply ss_refl ]).
- specialize (IHp (fun a => g a `; f) s).
  destruct IHp as (l1 & a & s' & Hss1).
  specialize (IHg a f s').
  destruct IHg as (l2 & b & s'' & Hss2).
  exists (l1 ++ l2). exists b. exists s''.
  abstract (eapply step_star_transitive; [
    eapply ss_step_None; [ apply s_bind  | apply Hss1 ]
  | exact Hss2
  ]).
- case b.
  + specialize (IHp1 f s).
    destruct IHp1 as (l & a & s' & Hss).
    exists l.
    exists a.
    exists s'.
    abstract (eapply ss_step_None; [ apply s_cond_true | apply Hss ]).
  + specialize (IHp2 f s).
    destruct IHp2 as (l & a & s' & Hss).
    exists l.
    exists a.
    exists s'.
    abstract (eapply ss_step_None; [ apply s_cond_false | apply Hss ]).
- revert s.
  induction n as [ | n' IHn ]; intro s.
  + exists []; exists tt; exists s.
    abstract (eapply ss_step_None; [ apply s_repeat_O | apply ss_refl ]).
  + destruct (IHp (fun _ => p_repeat n' p `; f) s) as (l1 & a1 & s1 & Hss1).
    destruct (IHn s1) as (l2 & a2 & s2 & Hss2).
    exists (l1 ++ l2); exists a2; exists s2.
    eapply ss_step_None; [ apply s_repeat_S | ].
    eapply step_star_transitive; [ eexact Hss1 | exact Hss2 ].
- revert s.
  induction fuel as [ | fuel' IHfuel ]; intro s.
  + exists []; exists tt; exists s.
    abstract (eapply ss_step_None; [ apply s_while_broke | apply ss_refl ]).
  + case_eq (c s); [ intro Htrue | intro Hfalse ].
    * destruct (IHp (fun _ => p_while fuel' c p `; f) s) as (l1 & a1 & s1 & Hss1).
      destruct (IHfuel s1) as (l2 & a2 & s2 & Hss2).
      exists (l1 ++ l2); exists a2; exists s2.
      eapply ss_step_None; [ apply s_while_true; exact Htrue | ].
      eapply step_star_transitive; [ eexact Hss1 | exact Hss2 ].
    * exists []; exists tt; exists s.
      abstract (eapply ss_step_None; [ apply s_while_false; exact Hfalse | apply ss_refl ]).
- exists []. exists s. exists s.
  abstract (eapply ss_step_None; [ apply s_get | apply ss_refl ]).
- exists []. exists tt. exists s'.
  abstract (eapply ss_step_None; [ apply s_put | apply ss_refl ]).
- exists [t]. exists tt. exists s.
  abstract (eapply ss_step_Some; [ apply s_mark | apply ss_refl ]).
Defined.

Definition run_ss {A : Type} (p : program A) (s : S) :
  {l & {a : A & {s' |
  step_star (s, p `; stop A) l (s', stop A a) } } } :=
  run_gen p (stop A) s.

End OperationalSemantics.

Arguments step {_ _} _ _ _.
Arguments step_star {_ _} _ _ _.
Arguments run_s {_ _ _} _ _ _.
Arguments run_s_n {_ _} _ {_} _ _ _.
Arguments run_ss {_ _ _} _ _.

Local Open Scope monae_scope.

Section DenotationalSemantics.

Variables S T : Type.
Variable M : stateTraceMonad S T.

Fixpoint denote {A} (p : program A) : M A :=
  match p with
  | p_ret _ v => Ret v
  | p_bind _ _ m f => denote m >>= (denote \o f)
  | p_cond _ b p1 p2 => if b then denote p1 else denote p2
  | p_repeat n p => (fix loop m : M unit :=
    if m is m'.+1 then denote p >> loop m' else Ret tt) n
  | p_while fuel c p => (fix loop m : M unit :=
    if m is m'.+1 then
      (st_get >>= (fun s =>
      if c s then denote p >> loop m' else Ret tt))
    else Ret tt) fuel
  | p_get => st_get
  | p_put s' => st_put s'
  | p_mark t => st_mark t
  end.

Notation "'Repeat' n {{ p }}" := (
  (fix loop (m : nat) : M unit :=
   match m with
   | 0 => Ret tt
   | m'.+1 => denote p >> loop m'
   end) n) (at level 200).

Notation "'While' fuel @ c {{ p }}" := (
  (fix loop (m : nat) : M unit :=
   match m with
   | 0 => Ret tt
   | m'.+1 =>
     st_get >>= (fun s =>
     if c s then denote p >> loop m' else Ret tt)
   end) fuel) (at level 200).

Fixpoint denote_continuation (k : continuation) : M (@continuation T S) :=
  match k with
  | stop A a => Ret (stop A a)
  | p `; f => denote p >>= (denote_continuation \o f)
  end.

Definition stateTrace_sub A (m : M A) : Type :=
  { p | denote p = m }.

Definition continuation_sub (m : M continuation) : Type :=
  {k | denote_continuation k = m }.

End DenotationalSemantics.

Arguments denote {S} {T} M A.
Arguments denote_continuation {S} {T} M.

Section semantics_equivalence.

Variables S T : Type.
Variable M : stateTraceReifyMonad S T.

Lemma denote_prefix_preserved A (m : M A) :
  stateTrace_sub m -> forall s s' l1 l a,
  reify m (s, l1) = Some (a, (s', l)) ->
  exists l2, l = l1 ++ l2.
Proof.
case=> p <-{m}.
induction p as [ A a | A B p IHp g IHg | A b p1 IHp1 p2 IHp2 |
  n p IHp | fuel c p IHp | | s0 | t ]; cbn;
 intros s s' l1 l a' Heq.
- exists [].
  rewrite cats0.
  by move: Heq; rewrite reifyret => -[].
- rewrite reifybind in Heq.
  case_eq (reify (denote M _ p) (s, l1)).
  + intros (a, (s0, l0)) Hp.
    rewrite Hp in Heq.
    move/IHp : Hp => [l2 Hp].
    move/IHg : Heq => [l2' Heq].
    exists (l2 ++ l2').
    by rewrite Heq Hp catA.
  + intro Hp.
    rewrite Hp in Heq.
    discriminate Heq.
- destruct b; [ eapply IHp1 | eapply IHp2 ]; exact Heq.
- revert s l1 Heq.
  induction n as [ | n' IH ]; intros s l1 Heq.
  + exists [].
    rewrite cats0.
    by move: Heq; rewrite reifyret => -[].
  + rewrite reifybind in Heq.
    case_eq (reify (denote M _ p) (s, l1)).
    * intros (a, (s0, l0)) Hp.
      move: (IHp _ _ _ _ _ Hp) => [l2 ?].
      subst l0.
      rewrite Hp in Heq.
      move: (IH _ _ Heq) => [l3 ?].
      exists (l2 ++ l3).
      by rewrite catA.
    * intro Hp.
      rewrite Hp in Heq.
      discriminate Heq.
- revert s l1 Heq.
  induction fuel as [ | fuel' IH ]; intros s l1 Heq.
  + exists [].
    rewrite cats0.
    by move: Heq; rewrite reifyret => -[].
  + rewrite reifybind reifystget in Heq.
    simpl in Heq.
    destruct (c s).
    * rewrite reifybind in Heq.
      case_eq (reify (denote M _ p) (s, l1)).
     -- intros (a ,(s0, l0)) Hp.
        move: (IHp _ _ _ _ _ Hp) => [l2 ?].
        subst l0.
        rewrite Hp in Heq.
        move: (IH _ _ Heq) => [l3 ?].
        exists (l2 ++ l3).
        by rewrite catA.
     -- intro Hp.
        rewrite Hp in Heq.
        discriminate Heq.
    * exists [].
      rewrite cats0.
      by move: Heq; rewrite reifyret => -[].
- exists [].
  rewrite cats0.
  by move: Heq; rewrite reifystget => -[].
- exists [].
  rewrite cats0.
  by move: Heq; rewrite reifystput => -[].
- exists [t].
  by move: Heq; rewrite reifystmark -cats1 => -[].
Qed.

Lemma denote_prefix_independent A (m : M A) :
  stateTrace_sub m -> forall s l1 l2,
  reify m (s, l1 ++ l2) =
  let res := reify m (s, l2) in
  match res with
  | None => None
  | Some res => Some (res.1, (res.2.1, l1 ++ res.2.2))
  end.
Proof.
intros [ p Hp ] s l1 l2.
subst m.
elim: p s l1 l2 => /= {A} [A a|A B p1 IH1 p2 IH2|A b p1 IH1 p2 IH2|
  n p IHp|fuel c p IHp||s'|t] s l1 l2.
- by rewrite !reifyret.
- rewrite [in LHS]reifybind [in LHS]IH1.
  rewrite [in RHS]reifybind.
  case: (reify (denote M _ p1) (s, l2)) => [[a' [s' l']] | ] /=.
  + by rewrite IH2.
  + reflexivity.
- by case: ifPn => _; [rewrite IH1|rewrite IH2].
- revert s l2.
  induction n as [ | n' IH ]; intros s l2.
  + by rewrite !reifyret.
  + do 2 rewrite reifybind.
    rewrite {}IHp.
    case_eq (reify (denote M _ p) (s, l2)).
    * intros (a, (s0, l0)) Hp.
      exact: IH.
    * reflexivity.
- revert s l2.
  induction fuel as [ | fuel' IH ]; intros s l2.
  + by rewrite !reifyret.
  + do 2 rewrite reifybind reifystget.
    cbn.
    destruct (c s).
    * do 2 rewrite reifybind.
      rewrite IHp.
      clear IHp.
      case_eq (reify (denote M _ p) (s, l2)).
     -- intros (a, (s0, l0)) Hp.
        exact: IH.
     -- reflexivity.
    * by rewrite !reifyret.
- by rewrite !reifystget.
- by rewrite !reifystput.
- by rewrite !reifystmark rcons_cat.
Qed.

Lemma denote_continuation_prefix_independent (m : M _) :
  continuation_sub m -> forall s l1 l2,
  reify m (s, l1 ++ l2) =
  let res := reify m (s, l2) in
  match res with
  | None => None
  | Some res => Some (res.1, (res.2.1, l1 ++ res.2.2))
  end.
Proof.
intros [ k Hk ].
subst m.
elim: k => // [A a s l1 l2|A p k IH s l1 l2].
by rewrite !reifyret.
rewrite /= !reifybind.
rewrite denote_prefix_independent /=; [ | now exists p ].
destruct (reify (denote M _ p) (s, l2)) as [ (a, (s', l)) | ].
- by rewrite IH.
- reflexivity.
Qed.

Lemma step_None_correct s s' k k' l :
  step (s, k) None (s', k') ->
  reify (denote_continuation M k) (s, l) = reify (denote_continuation M k') (s', l).
Proof.
intro Hstep.
remember (s, k) as sk eqn: Heq.
remember None as o eqn: Heqo.
remember (s', k') as sk' eqn: Heq'.
revert s s' k k' l Heq Heq' Heqo.
induction Hstep as
 [ s A a f | s A B p f g | s A p1 p2 k | s A p1 p2 k |
   s p k | s n p k | fuel s c p k Htrue | fuel s c p k Hfalse | s c p k |
   s f | s s' f | s t f ];
 intros s1 s2 k1 k2 l [= Hs1 Hk1] [= Hs2 Hk2] Heqo.
- subst s1 k1 s2 k2.
  by rewrite /= reifybind reifyret.
- subst s1 k1 s2 k2.
  cbn.
  by rewrite bindA.
- subst s1 s2 k1 k2.
  reflexivity.
- subst s1 s2 k1 k2.
  reflexivity.
- subst.
  cbn.
  rewrite bindretf.
  reflexivity.
- subst.
  cbn.
  rewrite bindA.
  reflexivity.
- subst.
  cbn.
  rewrite bindA reifybind reifystget Htrue bindA.
  reflexivity.
- subst.
  cbn.
  rewrite bindA reifybind reifystget Hfalse bindretf.
  reflexivity.
- subst.
  cbn.
  rewrite bindretf.
  reflexivity.
- subst s1 k1 s2 k2.
  by rewrite /= reifybind reifystget.
- subst s1 k1 s2 k2.
  by rewrite /= reifybind reifystput.
- discriminate Heqo.
Qed.

Lemma step_Some_correct s s' k k' t l :
  step (s, k) (Some t) (s', k') ->
  reify (denote_continuation M k) (s, l) =
  reify (denote_continuation M k') (s', rcons l t).
Proof.
intro Hstep.
remember (s, k) as sk eqn: Heq.
remember (Some t) as o eqn: Heqo.
remember (s', k') as sk' eqn: Heq'.
revert s s' k k' l Heq Heq' Heqo.
induction Hstep as
 [ s A a f | s A B p f g | s A p1 p2 k | s A p1 p2 k |
   s p k | s n p k | fuel s c p k Htrue | fuel s c p k Hfalse | s c p k |
   s f | s s' f | s t' f ];
 intros s1 s2 k1 k2 l [= Hs1 Hk1] [= Hs2 Hk2] Heqo; try discriminate Heqo.
subst s1 k1 s2 k2.
injection Heqo; intro; subst t.
by rewrite /= reifybind reifystmark.
Qed.

Lemma step_star_correct_gen s s' k k' l l' :
  step_star (s, k) l' (s', k') ->
  reify (denote_continuation M k) (s, l) = reify (denote_continuation M k') (s', l++l').
Proof.
intro Hstep_star.
remember (s, k) as sk eqn: Heq.
remember (s', k') as sk' eqn: Heq'.
revert s s' k k' l Heq Heq'.
induction Hstep_star as
 [ s |
  (s, k) (s', k') (s'', k'') l' Hstep Hstep_star IH |
  (s, k) (s', k') (s'', k'') t l' Hstep Hstep_star IH ];
 intros s1 s2 k1 k2 l1 Heq1 Heq2.
- rewrite cats0.
  by move: Heq2; rewrite Heq1 => -[<- <-].
- move: Heq1 Heq2 => [<- <-] [<- <-].
  apply step_None_correct with (l := l1) in Hstep.
  rewrite Hstep.
  apply IH; reflexivity.
- move: Heq1 Heq2 => [<- <-] [<- <-].
  apply step_Some_correct with (l := []) in Hstep.
  rewrite <- cats0 at 1.
  rewrite denote_continuation_prefix_independent; [ | now exists k ].
  rewrite -> Hstep, (IH _ s'' _ k'');
   [ | reflexivity | reflexivity ].
  cbn.
  rewrite denote_continuation_prefix_independent; [ reflexivity | ].
  now eexists.
Qed.

Proposition step_star_correct
  (s s' : S) (A : Type) (a : A) (p : program A) (l : list T) :
  step_star (s, p `; stop A) l (s', stop A a) ->
  reify (denote M _ p) (s, []) = Some (a, (s', l)).
Proof.
intro Hss.
apply step_star_correct_gen with (l := []) in Hss.
move: Hss.
rewrite /= reifyret reifybind.
destruct (reify (denote M _ p) (s, [])) as [[a'' [s'' l'']] | ].
- rewrite reifyret => -[Heq3 <- <-].
  apply inj_pair2 in Heq3.
  by rewrite Heq3.
- discriminate.
Qed.

Lemma step_star_complete_gen
  (s s' : S) (A : Type) (a : A) (p : program A) (l1 l2 : list T) f :
  reify (denote M _ p) (s, l1) = Some (a, (s', l1 ++ l2)) ->
  step_star (s, p `; f) l2 (s', f a).
Proof.
revert s s' a l1 l2 f.
induction p as [ A a | A B p IHp g IHg | A b p1 IHp1 p2 IHp2 |
  n p IHp | fuel c p IHp | | s0' | t ]; cbn;
 intros s s' a' l1 l2 f Heq.
- rewrite reifyret in Heq.
  injection Heq; clear Heq; intros; subst a' s'.
  replace l2 with (@nil T) by
   (revert l2 H; induction l1; [ tauto | intros ? [=]; firstorder ]).
  eapply ss_step_None; [ apply s_ret | apply ss_refl ].
- eapply ss_step_None.
  + apply s_bind.
  + move: Heq.
    rewrite reifybind.
    case_eq (reify (denote M _ p) (s, l1)).
    intros (a, (s0, l0)) Hp Heq.
    move: (denote_prefix_preserved ltac:(now eexists) Hp) => [l3 Hl3].
    rewrite Hl3 in Hp.
    apply IHp with (f := (fun a => g a `; f)) in Hp.
    clear IHp.
    move: (denote_prefix_preserved ltac:(now eexists) Heq) => [l4 Hl4].
    rewrite Hl4 in Heq.
    apply IHg with (f := f) in Heq.
    clear IHg.
    subst l0.
    replace l2 with (l3 ++ l4) by
     (induction l1; cbn in Hl4; [ congruence | injection Hl4; tauto ]).
    eapply step_star_transitive.
    * exact Hp.
    * exact Heq.
    * discriminate.
- destruct b; [
    eapply ss_step_None; [
      apply s_cond_true
    | apply IHp1 with (l1 := l1); exact Heq ]
  | eapply ss_step_None; [
      apply s_cond_false
    | apply IHp2 with (l1 := l1); exact Heq ]
  ].
- revert s l1 l2 Heq.
  induction n as [ | n' IHn ]; intros s l1 l2 Heq.
  + rewrite reifyret in Heq.
    injection Heq; clear Heq; intros; subst a' s'.
    replace l2 with (@nil T) by
     (revert l2 H; induction l1; [ tauto | intros ? [=]; firstorder ]).
    eapply ss_step_None; [ apply s_repeat_O | apply ss_refl ].
  + rewrite reifybind in Heq.
    case_eq (reify (denote M _ p) (s, l1)).
    * intros (a, (s0, l0)) Hp.
      rewrite Hp in Heq.
      move: (denote_prefix_preserved ltac:(now eexists) Hp) => [l3 Hl3].
      rewrite Hl3 {l0 Hl3} in Hp, Heq.
      specialize (IHp _ _ _ _ _ (fun _ => p_repeat n' p `; f) Hp).
      assert (Heq':
       reify (denote M _ (p_repeat n' p)) (s0, l1 ++ l3) = Some (a', (s', l1 ++ l2)))
       by apply Heq.
      move: (denote_prefix_preserved ltac:(now eexists) Heq') => [l4 Hl4].
      rewrite Hl4 in Heq.
      eapply ss_step_None; [ apply s_repeat_S | ].
      have -> : l2 = l3 ++ l4.
        by move/(congr1 (drop (size l1))) : Hl4; rewrite -catA ?drop_size_cat.
      eapply step_star_transitive; [ eexact IHp | eapply IHn; eexact Heq ].
    * intro Hp.
      rewrite Hp in Heq.
      discriminate.
- revert s l1 l2 Heq.
  induction fuel as [ | fuel' IHn ]; intros s l1 l2 Heq.
  + rewrite reifyret in Heq.
    injection Heq; clear Heq; intros; subst a' s'.
    replace l2 with (@nil T) by
     (revert l2 H; induction l1; [ tauto | intros ? [=]; firstorder ]).
    eapply ss_step_None; [ apply s_while_broke | apply ss_refl ].
  + rewrite reifybind reifystget in Heq.
    cbn in Heq.
    case_eq (c s); [ intro Htrue | intro Hfalse ].
    * rewrite Htrue reifybind in Heq.
      case_eq (reify (denote M _ p) (s, l1)).
     -- intros (a, (s0, l0)) Hp.
        rewrite Hp in Heq.
        move: (denote_prefix_preserved ltac:(now eexists) Hp) => [l3 Hl3].
        rewrite Hl3 {l0 Hl3} in Hp, Heq.
        specialize (IHp _ _ _ _ _ (fun _ => p_while fuel' c p `; f) Hp).
        assert (Heq':
         reify (denote M _ (p_while fuel' c p)) (s0, l1 ++ l3) = Some (a', (s', l1 ++ l2)))
         by apply Heq.
        move: (denote_prefix_preserved ltac:(now eexists) Heq') => [l4 Hl4].
        rewrite Hl4 in Heq.
        eapply ss_step_None; [ apply s_while_true; exact Htrue | ].
        have -> : l2 = l3 ++ l4.
          by move/(congr1 (drop (size l1))) : Hl4; rewrite -catA ?drop_size_cat.
        eapply step_star_transitive; [ eexact IHp | eapply IHn; eexact Heq ].
     -- intro Hp.
        rewrite Hp in Heq.
        discriminate.
    * move: Heq; rewrite Hfalse reifyret.
      move=> [<- <-] /(congr1 (drop (size l1))).
      rewrite drop_size_cat // drop_size => <-.
      eapply ss_step_None; [ apply s_while_false; exact Hfalse | apply ss_refl ].
- move: Heq; rewrite reifystget.
  move=> [<- <-] /(congr1 (drop (size l1))).
  rewrite drop_size_cat // drop_size => <-.
  eapply ss_step_None; [ apply s_get | apply ss_refl ].
- move: Heq; rewrite reifystput.
  move=> [<- <-] /(congr1 (drop (size l1))).
  rewrite drop_size_cat // drop_size => <-.
  eapply ss_step_None; [ apply s_put | apply ss_refl ].
- move: Heq; rewrite reifystmark.
  move=> [<- <-] /(congr1 (drop (size l1))).
  rewrite drop_size_cat // drop_rcons // drop_size => <-.
  eapply ss_step_Some; [ apply s_mark | apply ss_refl ].
Qed.

Proposition step_star_complete
  (s s' : S) (A : Type) (a : A) (p : program A) (l : list T) :
  reify (denote M _ p) (s, []) = Some (a, (s', l)) ->
  step_star (s, p `; stop A) l (s', stop A a).
Proof.
intro Hp.
apply step_star_complete_gen with (l1 := []).
exact Hp.
Qed.

End semantics_equivalence.

Notation "'eT' x y" := (@existT _ _ x y) (at level 200).
Notation "'e' x" := (@exist _ _ x _) (at level 200).

Definition p_nonce : program nat :=
  p_do n <- p_get;
  p_do _ <- p_put (S n);
  p_do _ <- p_mark n;
  p_ret n.

(*Definition M := @ModelStateTraceReify.mk.*)

Eval unfold denote, p_nonce in denote _ nat p_nonce.

Local Open Scope do_notation.

Definition nonce : (StateMonad.acto (nat * seq nat)%type) nat :=
  do n : nat <- st_get;
  do _ : unit <- st_put (S n);
  do _ : unit <- st_mark n;
  Ret n.

Compute nonce (0, []).
Compute (denote ([the stateTraceMonad nat nat of (StateMonad.acto (nat * seq nat)%type)]) nat p_nonce) (0, []).
Compute run_ss p_nonce 0.

Remark denote_p_nonce : denote _ nat p_nonce = nonce.
Proof. by []. Qed.

Program Example p_nonce_twice : program bool_eqType :=
  p_do nonce <- p_ret (
    p_do n : nat <- p_get;
    p_do _ : unit <- p_put (S n);
    p_do _ : unit <- p_mark n;
    p_ret n ) ;
  p_do x <- nonce ;
  p_do y <- nonce ;
  p_ret (x == y).

Example nonce_twice : [the stateTraceMonad nat nat of (StateMonad.acto (nat * seq nat)%type)] _ :=
  do nonce <- Ret (
    do n : nat <- st_get;
    do _ : unit <- st_put (S n);
    do _ : unit <- st_mark n;
    Ret n ) ;
  do x <- nonce ;
  do y <- nonce ;
  Ret (Nat.eqb x y).

Compute nonce_twice (0, []).
Compute (denote ([the stateTraceMonad nat nat of (StateMonad.acto (nat * seq nat)%type)]) bool p_nonce_twice) (0, []).
Compute run_ss p_nonce_twice 0.

Remark denote_p_nonce_twice :
  denote _ bool p_nonce_twice = nonce_twice.
Proof. by []. Qed.

Fixpoint countdown (fuel : nat) : [the stateTraceMonad nat bool of (StateMonad.acto (nat * seq bool)%type)] unit :=
  match fuel with
  | O => Ret tt
  | S fuel' =>
    do n <- st_get ;
    if (n == 0) then
      st_mark true
    else
      do _ <- st_mark false ; do _ <- st_put (n-1) ; countdown fuel'
  end.

Fixpoint p_countdown (fuel : nat) : program unit :=
  match fuel with
  | O => p_ret tt
  | S fuel' =>
    p_do n <- p_get ;
    p_cond (n == 0) (
      p_mark true
    ) (
      p_do _ <- p_mark false ; p_do _ <- p_put (n-1) ; p_countdown fuel'
    )
  end.

Compute (countdown 100) (5, []).
Compute (denote [the stateTraceMonad nat bool of (StateMonad.acto (nat * seq bool)%type)] unit (p_countdown 100)) (5, []).
Compute run_ss (p_countdown 100) 5.

Remark denote_countdown fuel :
  denote ([the stateTraceMonad nat bool of (StateMonad.acto (nat * seq bool)%type)]) unit (p_countdown fuel) = countdown fuel.
Proof.
elim: fuel => // n.
rewrite [countdown (S n)]/=.
by move <-.
Qed.

Example p_multiply (a b : nat) : program (T := unit) unit :=
  p_do _ <- p_put 0 ;
  p_repeat b (
    p_do x <- p_get ;
    p_put (a + x)
  ).

Compute run_ss (p_multiply 3 7) 0.

Example p_division (a b : nat) : program (T := unit) unit :=
  p_do _ <- p_put (a, 0);
  p_while a (fun s => b <= fst s) (
    p_do s <- p_get ;
    p_put (fst s - b, S (snd s))
  ).

Compute run_ss (p_division 22 7) (0, 0).

Compute run_s_n 15 (p_division 22 7) (stop unit) (0, 0).


Require Import List Arith Lia Morphisms Setoid.
From Undecidability.HOU Require Import calculus.calculus.
From Undecidability.HOU Require Import
        unification.higher_order_unification unification.nth_order_unification
        concon.conservativity_constants concon.conservativity concon.constants.
Import ListNotations.

(* ** Goldfarb sharp *)

From Undecidability.HOU Require Import
   second_order.diophantine_equations second_order.goldfarb.reduction.

Definition gonly : Const :=
  {|
    const_type := option False;
    ctype := fun o => match o with
                  | None => alpha → alpha → alpha
                  | Some f => match f with end
                  end

  |}.

#[global]
Program Instance RE_ag_gonly : retract gonly ag :=
  {|
    I := fun _ => None;
    R := fun x => match x with None => Some None | _ => None end
  |}.
Next Obligation.
  now destruct x as [[]|].
Qed.

Lemma Goldfarb_remove:
  H10 ⪯ OU 2 ag /\ OU 2 ag ⪯ OU 2 gonly.
Proof.
  split. eapply Goldfarb.
  eapply (@remove_constants_reduction ag gonly); eauto.
  intros [[]|]; cbn; eauto.
  intros [[[]|]|]; cbn; eauto.
  destruct eq_dec; intuition  discriminate.
Qed.

Lemma Goldfarb_sharp (C: Const) (re: retract gonly C):
  ctype C (I None) = alpha → alpha → alpha -> OU 2 gonly ⪯ OU 2 C.
Proof.
  intros. eapply unification_constants_monotone; eauto.
  intros [[]|]; cbn; eauto.
Qed.

Definition cfree : Const :=
  {|
    const_type := False;
    ctype := fun f => match f with end
  |}.

#[global]
Program Instance RE_cfree X : retract cfree X :=
  {|
    I := fun f => match f with end;
    R := fun x => None
  |}.

Lemma Goldfarb_Huet X:
  OU 2 gonly ⪯ OU 3 gonly /\
  OU 3 gonly ⪯ OU 3 cfree /\
  OU 3 cfree ⪯ OU 3 X.
Proof.
  repeat split.
  eapply unification_step; eauto.
  eapply remove_constants_reduction; eauto.
  intros []. intros [[]|]; cbn; eauto.
  eapply unification_constants_monotone; eauto.
  intros [].
Qed.