(** This is a toy example to demonstrate how to specify and prove correct a C function using C light *)

From Coq Require Import String List ZArith Psatz.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs Memory Values ClightBigstep Events Maps.

(* Specification of the strlen function *)
Inductive strlen (m : mem) (b : block) (ofs : ptrofs) : nat -> Prop :=
| LengthZero: Mem.loadv Mint8signed m (Vptr b ofs) = Some (Vint Int.zero) -> strlen m b ofs 0
| LengthSucc: forall n c,
    Z.of_nat (S n) < Int.modulus -> (* no int overflow *)
    Ptrofs.unsigned ofs + 1 < Ptrofs.modulus -> (* no ofs overflow *)
    strlen m b (Ptrofs.add ofs Ptrofs.one) n ->
    Mem.loadv Mint8signed m (Vptr b ofs)  = Some (Vint c) ->
    c <> Int.zero ->
    strlen m b ofs (S n).

(* strlen C light AST *)
Definition _output : ident := 4%positive.
Definition _input : ident := 3%positive.
Definition _t'1 : ident := 7%positive.
Definition _t'2 : ident := 8%positive.

Definition f_strlen := {|
  fn_return := tuint;
  fn_callconv := cc_default;
  fn_params := ((_input, (tptr tuchar)) :: nil);
  fn_vars := nil;
  fn_temps := ((_output, tuint) :: (_t'1, (tptr tschar)) :: (_t'2, tschar) :: nil);
  fn_body :=
(Ssequence
  (Sset _output (Econst_int (Int.repr 0) tint))
  (Ssequence
    (Sloop
      (Ssequence
        (Ssequence
          (Ssequence
            (Sset _t'1 (Etempvar _input (tptr tschar)))
            (Sset _input
              (Ebinop Oadd (Etempvar _t'1 (tptr tschar))
                (Econst_int (Int.repr 1) tint) (tptr tschar))))
          (Ssequence
            (Sset _t'2 (Ederef (Etempvar _t'1 (tptr tschar)) tschar))
            (Sifthenelse (Etempvar _t'2 tschar) Sskip Sbreak)))
        (Sset _output
          (Ebinop Oadd (Etempvar _output tuint) (Econst_int (Int.repr 1) tint)
            tuint)))
      Sskip)
    (Sreturn (Some (Etempvar _output tuint)))))
                          |}.

Definition f_strlen_loop :=
  (Sloop
      (Ssequence
        (Ssequence
          (Ssequence
            (Sset _t'1 (Etempvar _input (tptr tschar)))
            (Sset _input
              (Ebinop Oadd (Etempvar _t'1 (tptr tschar))
                (Econst_int (Int.repr 1) tint) (tptr tschar))))
          (Ssequence
            (Sset _t'2 (Ederef (Etempvar _t'1 (tptr tschar)) tschar))
            (Sifthenelse (Etempvar _t'2 tschar) Sskip Sbreak)))
        (Sset _output
          (Ebinop Oadd (Etempvar _output tuint) (Econst_int (Int.repr 1) tint)
            tuint)))
      Sskip).

Definition f_strlen_loop_body := (Ssequence
        (Ssequence
          (Ssequence
            (Sset _t'1 (Etempvar _input (tptr tschar)))
            (Sset _input
              (Ebinop Oadd (Etempvar _t'1 (tptr tschar))
                (Econst_int (Int.repr 1) tint) (tptr tschar))))
          (Ssequence
            (Sset _t'2 (Ederef (Etempvar _t'1 (tptr tschar)) tschar))
            (Sifthenelse (Etempvar _t'2 tschar) Sskip Sbreak)))
        (Sset _output
          (Ebinop Oadd (Etempvar _output tuint) (Econst_int (Int.repr 1) tint)
                  tuint))).

(* Our goal is to prove that the C light AST is equivalent satisfies the spec: in this context it means that the C light AST evaluates to the correct value wrt to big step operational semantics *)

(* Some useful notation and tactics *)

Definition chunk : memory_chunk := Mint8signed.
Definition VintZ := fun (z : Z) => Vint (Int.repr z).
Definition VintN:= fun n => Vint (Int.repr(Z_of_nat n)).

Notation gso := PTree.gso.
Notation gss := PTree.gss.

(* Tactics for arithmetic on ptrofs, now they are ad hoc, TODO: automatize translation from ptrofs to Z *)

Ltac ints_to_Z :=
  repeat rewrite Int.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac ptrofs_to_Z :=
  repeat rewrite Ptrofs.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac ptrofs_compute_add_mul :=
      simpl; unfold Ptrofs.add; unfold Ptrofs.mul; unfold Ptrofs.of_intu; unfold Ptrofs.of_int;
      repeat rewrite Ptrofs.unsigned_repr_eq;  repeat rewrite Int.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac ints_compute_add_mul :=
      simpl; unfold Int.add; unfold Int.mul;
      repeat rewrite Int.unsigned_repr_eq;  repeat rewrite Int.unsigned_repr_eq; repeat rewrite Zmod_small.

Ltac seq1 := eapply exec_Sseq_1.
Ltac seq2 := eapply exec_Sseq_2.
Ltac sset := eapply exec_Sset.
Ltac loop := eapply exec_Sloop_loop.

(* can make more generic to repeatedly apply gso *)
Ltac gso_assumption :=
  match goal with
  | [ H : ?P ! ?I = Some ?W |- (PTree.set _ _ ?P) ! ?I = Some ?Z ] => rewrite gso
  | [ H : ?P ! ?Q = Some ?W |-  ?P ! ?Q = Some ?Z ] => apply H
  | [ |- _ <> _ ] => cbv ; congruence
  end.

Proposition char_not_zero : forall c, c <> Int.zero -> true = (negb (Int.eq c Int.zero)).
Proof.
  intros.
  replace (Int.eq c Int.zero) with false.
  auto.
  rewrite Int.eq_false; intuition.
Qed.

Parameter ge : genv.
Parameter e : env.
(* Test *)
Lemma strlen_correct_test: forall m b ofs le,
    strlen m b ofs 2%nat ->
    le!_input = Some (Vptr b ofs) ->
    (* C light expression f_strlen returns O and assigns O to output variable *)
    exists t le', exec_stmt ge e le m f_strlen.(fn_body) t le' m (Out_return (Some ((VintZ 2),tuint))) /\ (le'!_output) = Some (VintZ 2).
Proof.
  intros until le. intro Spec.
  inversion_clear Spec. inversion_clear H1. inversion_clear H6.
  repeat eexists.
  - seq1.
    -- sset. (* evaluate expression *) repeat econstructor.
    -- seq1.
      * (* loop 1 *)
        loop. repeat econstructor. repeat gso_assumption. eapply gss. repeat econstructor.
        rewrite gso. apply gss. cbv. congruence. apply H2.
        apply gss.
        econstructor.
        replace (negb (Int.eq c Int.zero)) with true by (apply (char_not_zero c); assumption).
        econstructor.
         rewrite gso. rewrite gso. rewrite gso. apply gss. 1-3: cbv; congruence.
        repeat econstructor. econstructor. econstructor.

        (* loop 2 *)
        loop. repeat econstructor.
        rewrite gso. rewrite gso. apply gss. 1-2: cbv; congruence. apply gss.
        repeat econstructor.
        rewrite gso. apply gss. cbv; congruence.
        replace (Ptrofs.add ofs
          (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
             (ptrofs_of_int Signed (Int.repr 1)))) with (Ptrofs.add ofs Ptrofs.one) by (auto with ptrofs).
        apply H7.
        apply gss.
        econstructor.
        replace (negb (Int.eq c0 Int.zero)) with true by (apply (char_not_zero c0); assumption).
        econstructor.
        rewrite gso. rewrite gso. rewrite gso. apply gss. 1-3: cbv; congruence.
        repeat econstructor. econstructor. econstructor.

         (* exit loop *)
        eapply exec_Sloop_stop1.
        seq2. seq1. seq1. econstructor. econstructor. rewrite gso. rewrite gso. apply gss. 1-2: cbv; congruence.
        repeat econstructor.
        apply gss.
        repeat econstructor.
        seq1. repeat econstructor.
        rewrite gso. apply gss. cbv ; congruence.
        replace (Ptrofs.add
          (Ptrofs.add ofs
             (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
                (ptrofs_of_int Signed (Int.repr 1))))
          (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
             (ptrofs_of_int Signed (Int.repr 1))))  with (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) Ptrofs.one) by (auto with ptrofs).
        apply H1.
        repeat econstructor.
        apply gss.
        econstructor.
        replace (negb (Int.eq Int.zero Int.zero)) with false by (auto with ints).
        econstructor.
        cbv; congruence.
        econstructor.
      * (* return statement *)
        repeat econstructor.  rewrite gso.  rewrite gso. rewrite gso.  eapply gss. all: cbv; congruence.
  - rewrite gso.  rewrite gso.  rewrite gso. eapply gss. all: cbv; congruence.
Qed.
(* Helper lemmas about the specification *)

 (* add more lemmas from Compcert to ptrofs hints *)
Lemma int_ptrofs_mod_eq : (Int.modulus = Ptrofs.modulus).
Proof.
  cbv; split; congruence.
Qed.

Hint Resolve Ptrofs.mul_one Ptrofs.add_zero int_ptrofs_mod_eq : ptrofs.

Lemma strlen_to_len_0 : forall len m b ofs, strlen m b ofs len -> strlen m b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat len))) O.
Proof.
  induction len; intros.
  - simpl.  replace (Ptrofs.repr 0) with Ptrofs.zero by (auto with ptrofs).
    replace (Ptrofs.add ofs Ptrofs.zero) with ofs by (auto with ptrofs).
    assumption.
  - inversion_clear H.
    replace (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S len)))) with
    (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) (Ptrofs.repr (Z.of_nat len))).
    apply (IHlen m b (Ptrofs.add ofs Ptrofs.one) H2).
    { rewrite Nat2Z.inj_succ.
      replace  (Z.succ (Z.of_nat len)) with ((Z.of_nat len) + 1) by (auto with zarith).
      unfold Ptrofs.one.
      symmetry.
      rewrite Ptrofs.add_assoc.
      f_equal.
      ptrofs_compute_add_mul.
      all: pose  int_ptrofs_mod_eq; try nia.
      f_equal. auto with zarith. }
Qed.

Lemma strlen_to_mem : forall len m b ofs, strlen m b ofs len ->
                                     forall i, (i < len)%nat -> exists c, Mem.loadv chunk m (Vptr b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) = Some (Vint c) /\ c <> Int.zero.
Proof.
  induction len.
  - intros. omega.
  -  induction i; intro; inversion_clear H.
     +  replace (Ptrofs.repr (Z.of_nat 0)) with Ptrofs.zero by (simpl; auto with ptrofs).
        replace (Ptrofs.add ofs Ptrofs.zero) with ofs by (auto with ptrofs).
       exists c. exact (conj H4 H5).
    +  assert (i < len)%nat by omega. pose (IHlen m b (Ptrofs.add ofs Ptrofs.one) H3 i H).
       replace (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i)))) with  (Ptrofs.add (Ptrofs.add ofs Ptrofs.one) (Ptrofs.repr (Z.of_nat i))).
       assumption.
       {
         rewrite Nat2Z.inj_succ.
         replace  (Z.succ (Z.of_nat i)) with ((Z.of_nat i) + 1) by (auto with zarith).
         unfold Ptrofs.one.
         ptrofs_compute_add_mul.
         f_equal.
         nia.
         all: pose int_ptrofs_mod_eq; try nia.
         destruct ofs; simpl in *.
         nia.
       }
Qed.

(* Correctness statements *)

Lemma strlen_loop_correct_gen :
  forall len i m b ofs le,
    (* we read a C string of length len + i from memory and len + i is a valid integer *)
    strlen m b ofs (len + i) ->
    (* THEN there is a trace t and local environment le' such that: *)
    forall t le',
      (* if output equals i in the starting local environment le *)
      le!_output = Some (VintN i) ->
      (* if input is an address [b,ofs + i] in the starting local environment *)
      le!_input = Some (Vptr b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) ->     (* then loop of strlen function executes to le' with output assigned len + i *)
      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN (len + i)).
Proof.

(* A generalization of loop correctness *)
Lemma strlen_loop_correct_gen :
  forall len i m b ofs le,
    (* we read a C string of length len + i from memory and len + i is a valid integer *)
    strlen m b ofs (len + i) ->
    (* THEN there is a trace t and local environment le' such that: *)
    exists t le',
      (* if output equals i in the starting local environment le *)
      le!_output = Some (VintN i) ->
      (* if input is an address [b,ofs + i] in the starting local environment *)
      le!_input = Some (Vptr b (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) ->     (* then loop of strlen function executes to le' with output assigned len + i *)
      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN (len + i)).
Proof.
  assert (Int.modulus <= Ptrofs.modulus) as B.
  { cbv. destruct Archi.ptr64. 1-2: congruence. }
  induction len; intros until le; intro Spec.
  - (* Base case *)
    simpl in Spec.
    repeat eexists.
    (* Exit the loop *)
    eapply exec_Sloop_stop1. seq2. repeat econstructor.
    apply H0.
    eapply gss.
    repeat econstructor.
    rewrite gso. apply gss. cbv. congruence.
    (* Derive memory assumptions from the specification *)
    pose (Spec_mem := strlen_to_len_0 i m b ofs Spec).
    inversion_clear Spec_mem.
    apply H1.
    apply gss.
    econstructor.
    replace (negb (Int.eq Int.zero Int.zero)) with false by (auto with ints).
    econstructor.
    cbv; congruence. econstructor.
    repeat (rewrite gso).
    replace (0 + i)%nat with i by lia.
    assumption.
    1-3: cbv; congruence.
  - (* Ind. Step *)
    assert (exists char, Mem.loadv Mint8signed m (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))) = Some (Vint char) /\ char <> Int.zero) as Mem.
    { refine (strlen_to_mem (S len + i) m b ofs Spec i _). omega. }
    destruct Mem as [char Mem].
    (* apply I.H. to le' after one step when starting with i and [b,ofs + i]  *)
    pose (le'' :=  (PTree.set _output (VintN (S i))
       (PTree.set _t'2 (Vint char) (PTree.set _input
               (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i)))))
          (PTree.set _t'1
               (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i))))
                      le))))).
    pose (IH := IHlen (S i)  m b ofs le'').
    assert ( exists (t : trace) (le' : temp_env),
       le'' ! _output = Some (VintN (S i)) ->
       le''! _input = Some (Vptr b  (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i))))) ->
       exec_stmt ge e le'' m f_strlen_loop t le' m
         Out_normal /\
       le' ! _output = Some (VintN (len + S i))) as Step.
    { eapply IH.
      replace (len + S i)%nat with (S len + i)%nat by omega.
      assumption. }
    destruct Step as [s Step]. destruct Step as [t Step].
    (* Do one loop on the goal: then apply IH *)
    repeat eexists.
    loop. repeat econstructor.
    apply H0.
    eapply gss.
    repeat econstructor.
    rewrite gso. apply gss. cbv; congruence.
    simpl. ptrofs_to_Z.
    apply Mem.
    apply gss.
    econstructor.
    replace (negb (Int.eq char Int.zero)) with true by (apply (char_not_zero char); apply Mem).
    econstructor.
    repeat (rewrite gso). apply H. 1-3: cbv; congruence.
    repeat econstructor. econstructor. econstructor.
    fold f_strlen_loop.
    replace (PTree.set _output
       (Vint (Int.add (Int.repr (Z.of_nat i)) (Int.repr 1)))
       (PTree.set _t'2 (Vint char)
          (PTree.set _input
             (Vptr b
                (Ptrofs.add
                   (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))
                   (Ptrofs.mul
                      (Ptrofs.repr (sizeof ge tschar))
                      (ptrofs_of_int Signed (Int.repr 1)))))
             (PTree.set _t'1
                (Vptr b
                   (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i))))
                le)))) with le''.
  eapply Step.
  apply gss.
  unfold le''. rewrite gso. rewrite gso. apply gss.
  1-2: cbv; congruence.

  { inversion Spec.
    unfold le''.
    replace (Vint (Int.add (Int.repr (Z.of_nat i)) (Int.repr 1))) with (VintN (S i)).
    replace (Ptrofs.add
                (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat i)))
                (Ptrofs.mul (Ptrofs.repr (sizeof ge tschar))
                            (ptrofs_of_int Signed (Int.repr 1)))) with (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat (S i)))).
    reflexivity.
    + rewrite Nat2Z.inj_succ.
      replace  (Z.succ (Z.of_nat i)) with ((Z.of_nat i) + 1) by (auto with zarith).
      simpl.
      replace  (Ptrofs.repr 1) with Ptrofs.one by (auto with ptrofs).
      replace  (Ptrofs.of_ints (Int.repr 1)) with Ptrofs.one by (auto with ptrofs).
      replace  (Ptrofs.mul Ptrofs.one Ptrofs.one) with (Ptrofs.one) by (auto with ptrofs).
      unfold Ptrofs.one.
      symmetry.
      rewrite Ptrofs.add_assoc.
      f_equal.
      ptrofs_compute_add_mul.
      auto.
      all: pose int_ptrofs_mod_eq; try nia.
    + unfold VintN.
      f_equal.
      ints_compute_add_mul.
      f_equal.
      lia.
      cbv. econstructor. 1-2: congruence.
      nia.
      }
  destruct Step.
  apply gss.
  unfold le''. rewrite gso. rewrite gso. apply gss.
  1-2: cbv; congruence.
  replace (S len + i)%nat with (len + S i)%nat by omega.
  assumption.
Qed.

(* Correctness of the loop execution *)
Lemma strlen_loop_correct: forall len m b ofs le, strlen m b ofs len -> exists t le', le!_output = Some (VintN O) ->
                                                                                le!_input = Some (Vptr b ofs) ->

      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN len).
Proof.
  intros.
  replace ofs with (Ptrofs.add ofs (Ptrofs.repr (Z.of_nat O))) by (auto with ptrofs).
  replace len with (len + O)%nat by lia.
  eapply strlen_loop_correct_gen.
  replace (len + O)%nat with len by omega.
  assumption.
Qed.

(* Full correctness statement *)
Lemma strlen_correct: forall len m b ofs le, strlen m b ofs len -> exists t le', le!_input = Some (Vptr b ofs) ->
                                                                               exec_stmt ge e le  m f_strlen.(fn_body) t le' m (Out_return (Some ((VintN len),tuint))).
Proof.
  intros.
  pose (Loop := strlen_loop_correct len  _ _ _ (PTree.set _output (Vint Int.zero) le) H). destruct Loop as [t Loop]. destruct Loop as [le' Loop].
  repeat eexists.
  intro input.
  assert ((PTree.set _output (Vint Int.zero) le) ! _output =
          Some (VintN 0)) as O by (apply gss).
  assert ((PTree.set _output (Vint Int.zero) le) ! _input =
          Some (Vptr b ofs)) as I.
  { rewrite gso. assumption. cbv; congruence. }
  destruct (Loop O I) as [Exec Out].
  seq1.
  repeat econstructor.
  seq1. fold f_strlen_loop.
  eapply Exec.
  repeat econstructor.
  eapply Out.
Qed.

(* Specification of the strlen function on integers *)

Definition no_int_overflow (i : int) := 0 < Int.unsigned i + 1 < Int.modulus.
Definition no_pointer_overflow (i : ptrofs) := 0 < Ptrofs.unsigned i + 1 < Int.modulus.

Definition Int_succ := fun i : int => Int.add i Int.one.

Inductive strlen_int (m : mem) (b : block) (ofs : ptrofs) : int -> Prop :=
| LengthZeroInt: Mem.loadv Mint8signed m (Vptr b ofs) = Some (Vint Int.zero) -> strlen_int m b ofs Int.zero
| LengthSuccInt: forall n c,
    no_pointer_overflow ofs -> (* this condition is superflous *)
    no_int_overflow n ->
    Mem.loadv Mint8signed m (Vptr b ofs)  = Some (Vint c) ->
    c <> Int.zero ->
    strlen_int m b (Ptrofs.add ofs Ptrofs.one) n ->
    strlen_int m b ofs (Int_succ n).

Lemma strlen_refine : forall m b ofs i, strlen_int m b ofs i -> strlen m b ofs (Z.to_nat (Int.unsigned i)).
Proof.
  intros.
  induction H.
  replace (Z.to_nat (Int.unsigned Int.zero)) with O by (auto with ints; nia).
  econstructor.
  assumption.
  replace (Z.to_nat (Int.unsigned (Int_succ n))) with (S (Z.to_nat (Int.unsigned n))).
  econstructor.
  unfold no_int_overflow in H0.
  replace  (S (Z.to_nat (Int.unsigned n))) with  ((Z.to_nat (Int.unsigned n)) + 1)%nat by omega.
  destruct n; simpl in *; try nia.
  Search Z.of_nat.
  rewrite Nat2Z.inj_add.
  Search Z.of_nat (Z.to_nat _).

  replace (Z.of_nat (Z.to_nat intval)) with intval.
  replace (Z.of_nat 1) with 1 by nia.
  nia.
  symmetry.
  (eapply Z2Nat.id).
  nia.
  unfold no_pointer_overflow in H.
  pose int_ptrofs_mod_eq;   nia.
  (* true *)
  assumption.
  apply H1.
  assumption.

  unfold no_int_overflow in H.
  unfold Int_succ.
  replace  (Int.unsigned (Int.add n Int.one)) with (Int.unsigned n + 1).
  replace  (S (Z.to_nat (Int.unsigned n))) with  ((Z.to_nat (Int.unsigned n)) + 1)%nat by omega.
  Search Z.to_nat.
  rewrite Z2Nat.inj_add.
  replace  (Z.to_nat 1) with 1%nat.
  auto.
  symmetry.
  unfold Z.to_nat.
  nia.
  destruct n; simpl in *; nia.
  nia.
  ints_compute_add_mul.
  all: replace (Int.unsigned Int.one) with 1 by (auto with ints).
  auto. unfold no_int_overflow in H0. nia.
  Qed.

(* Full correctness statement *)
Lemma strlen_correct_int: forall len m b ofs le,
      strlen_int m b ofs len -> exists t le',
      le!_input = Some (Vptr b ofs) ->
      exec_stmt ge e le  m f_strlen.(fn_body) t le' m (Out_return (Some ((Vint len),tuint))).
Proof.
  intros until le; intro Spec.
  pose (strlen_refine _ _ _ _  Spec) as S.
  pose (strlen_correct _ _ _  _  le   S).
  replace (VintN (Z.to_nat (Int.unsigned len))) with (Vint len) in e0.
  assumption.
  unfold VintN.
  f_equal.
  replace (Z.of_nat (Z.to_nat (Int.unsigned len))) with (Int.unsigned len).
  auto with ints.
  rewrite Z2Nat.id.
  auto.
  destruct len; simpl in *. nia.
Qed.

(* Functional spec *)
(* true if the integer value read is zero - end of string *)

Definition is_null (v : Values.val) :=
  match v with
  | Vint zero => true
  | _ => false
  end.

Definition INTSIZE := (nat_of_Z Int.modulus).

Fixpoint strlen_fun_spec (m : mem) (b : block) (ofs : ptrofs) (l: Z) (intrange : nat) {struct intrange} : option int :=
      match intrange with
      | O => None (* out of intrange *)
      | S n => match Mem.loadv chunk m (Vptr b ofs) with
              | Some v =>
                if is_null v
                then Some (Int.repr l) else strlen_fun_spec m b (Ptrofs.add ofs Ptrofs.one) (l + 1) n
              | None => None
              end
      end.

Definition strlen_fun (m : mem) (b: block) (ofs : ptrofs) :=  strlen_fun_spec m b ofs 0 INTSIZE.

(* Full correctness statement *)
Lemma strlen_correct_fun: forall len m b ofs le, strlen_fun m b ofs = Some len ->
                                            exists t le', le!_input = Some (Vptr b ofs) ->
      exec_stmt ge e le  m f_strlen.(fn_body) t le' m (Out_return (Some ((Vint len),tuint))).
Admitted.

(* Conditions about the f_strlen loop: an illustration *)

(* On empty string C light function evaluates to 0 *)
Lemma strlen_correct_loop_empty_string :
  forall ge e m b ofs le,
    strlen m b ofs O ->

    exists t le',
      le!_output = Some (VintN O) ->
      le!_input = Some (Vptr b ofs) ->
      exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ le'!_output = Some (VintN O).
Proof.
  intros.
  replace O with (0 + 0)%nat by lia.
  replace ofs with (Ptrofs.add ofs Ptrofs.zero) by (auto with ptrofs).
  eapply strlen_loop_correct_gen.
  simpl.
  assumption.
Qed.

(* If 0 is read from memory at [b,ofs + len] the output is set to len *)
Lemma strlen_loop_break_correct:  forall ge e m b ofs outp le,
      ofs + Z.of_nat outp < Ptrofs.modulus ->
      0 <= ofs < Ptrofs.modulus ->
      0 <= Z.of_nat outp < Ptrofs.modulus ->

      (* IF before the loop *s = [b,ofs + outp] and i = outp *)
      le!_input = Some (Vptr b (Ptrofs.repr (ofs + Z.of_nat outp))) ->
      le!_output = Some (VintN outp) ->

      (* and the guard condition is false *)
      Mem.load Mint8signed m b (ofs + (Z_of_nat outp)) = Some (Vint (Int.repr 0)) ->

      (* THEN loop executes to an environment with i = outp [i.e., i stays unchanged] + memory is unchanged *)
      exists t le', exec_stmt ge e le m f_strlen_loop t le' m Out_normal /\ (le'!_output) = Some (VintN outp).
Proof.
  intros.
  repeat eexists.
  eapply exec_Sloop_stop1.
  seq2. seq1. seq1.
  repeat econstructor.
  apply H2.
  repeat econstructor.
  apply gss.
  repeat econstructor.
  seq1.
  repeat econstructor.
  rewrite gso. apply gss. cbv ; congruence.
  simpl.
  replace (Ptrofs.unsigned (Ptrofs.repr (ofs + Z.of_nat outp))) with (ofs + Z.of_nat outp).
  apply H4.
  { ptrofs_compute_add_mul. all: lia. }
  repeat econstructor.
  apply gss.
  econstructor.
  replace (negb (Int.eq Int.zero Int.zero)) with false by (auto with ints).
  econstructor.
  cbv; congruence.
  econstructor.
  repeat (rewrite gso). assumption.
  all: cbv; congruence.
Qed.

Lemma strlen_loop_body_correct: Archi.ptr64 = false -> forall len ge e m b ofs le,
      0 <= ofs < Ptrofs.modulus ->
      Z_of_nat len < Int.modulus ->
      ofs + Z_of_nat len < Ptrofs.modulus ->

      le!_input = Some (Vptr b (Ptrofs.repr (ofs + Z.of_nat len))) ->
      le!_output = Some (VintN len) ->

      (exists c, Mem.load chunk m b (ofs + Z.of_nat len) = Some (Vint c) /\c <> Int.zero) ->

      exists t le', exec_stmt ge e le m f_strlen_loop_body t le' m Out_normal /\ le'!_output = Some (VintN (S len)).
Proof.
  intros.
  destruct H5 as [p].
  repeat eexists.
  repeat seq1.
  repeat econstructor. apply H3. repeat econstructor.
  apply gss.
  repeat econstructor.
  repeat econstructor.
  rewrite gso. apply gss. cbv; congruence.
  simpl.
  replace (Ptrofs.unsigned (Ptrofs.repr (ofs + Z.of_nat len))) with (ofs + Z.of_nat len).
  apply H5.
  { ptrofs_compute_add_mul. all: lia. }
  repeat econstructor.
  apply gss.
  econstructor.
  replace (negb (Int.eq p Int.zero)) with true.
  repeat econstructor.
  { replace (Int.eq p Int.zero) with false.
          auto.
          rewrite Int.eq_false.
          reflexivity.
          apply H5. }
  repeat econstructor.
  repeat (rewrite gso).
  apply H4. 1-3: cbv; congruence.
  repeat econstructor.
  unfold VintN.
  replace (Int.add (Int.repr (Z.of_nat len)) (Int.repr 1)) with (Int.repr (Z.of_nat (S len))).
  apply gss.
  { ints_compute_add_mul.
    f_equal.
    lia.
    split; try lia. cbv; auto.
    lia. }
Qed.


Require Export Arith.EqNat.
Require Export Arith.Lt.
Require Export Arith.Compare_dec.
Require Export List.
Require Import String.
Open Scope string_scope.
Require Import TacticsSF.
Require Import TacticsCPDT.
Require Import Process.
Require Import List.
Require Import PrettyPrinter.
Require Import TypeAssignmentPoly.
Require Import ResultBasics.
Require Import ExampleCommon.
Require Import ExampleRecursion.

(* ------------ abp-send ------------------*)

(*
  proc send_i(x, in, err1) =
   err1!i;err1!x;send_i(x, in, err1)   Send message x (maybe a duplicate)
   +err1?(1 − i);send_i(x, in, err1)   Ignore duplicate ack 1−i
   +err1?i;in?y;send_{1-i}(y, in, err1)  New ack i, send next message y from in
*)

Definition abp_sendA_procR (i : bool) : procR :=
(* err1!i;err1!x;send_i(x, in, err1) *)
(OutputR (var_value_of_string "err1") (token_value_of_bool i)
  (OutputR (var_value_of_string "err1") (var_value_of_string "x")
    (RecurseR ("send_"++(string_of_bool i))
      ((var_value_of_string "x") :: (var_value_of_string "in")
        :: (var_value_of_string "err1") :: nil)))).

Definition abp_sendB_procR (i : bool) : procR :=
(* err1?z;[z=(1 − i)];send_i(x, in, err1) *)
(InputR (var_value_of_string "err1")
  (IsEqR (ValVariable (Var (Bound 0))) (token_value_of_bool (negb i))
    (RecurseR ("send_"++(string_of_bool i)) ((var_value_of_string "x")
      :: (var_value_of_string "in") :: (var_value_of_string "err1") :: nil)))).

Definition abp_sendC_procR (i : bool) : procR :=
(* err1?z;[z=i];in?y;send_{1-i}(y, in, err1) *)
(InputR (var_value_of_string "err1")
  (IsEqR (ValVariable (Var (Bound 0))) (token_value_of_bool i)
    (InputR (var_value_of_string "in")
      (RecurseR ("send_"++(string_of_bool (negb i)))
        ((ValVariable (Var (Bound 0))) :: (var_value_of_string "in")
          :: (var_value_of_string "err1") :: nil))))).

(*
   err1!i;err1!x;send_i(x, in, err1)
+  err1?z;[z=(1 − i)];send_i(x, in, err1)
+  err1?z;[z=i];in?y;send_{1-i}(y, in, err1)
*)
Definition abp_send_procR (i : bool) : procR :=
  SumR (abp_sendA_procR i) (SumR (abp_sendB_procR i) (abp_sendC_procR i)).

Definition abp_send x inp err1 :=
  let mkTriple i := (String.append "send_" (string_of_bool i),
      "x" :: "in" :: "err1" :: nil, abp_send_procR i) in
  createRecProc (map mkTriple (false :: true :: nil)) "send_false"
    (x :: inp :: err1 :: nil).

Definition abp_send_test : proc :=
  abp_send (var_value_of_string "qx") (var_value_of_string "qin")
    (var_value_of_string "qerr1").

(*

NOTES:

Eval compute in abp_send_test.

Eval compute in
  (undebruijn_proc 50
    ("send_false" % "send_true" %
      (("xc" % "x" % "xin" % "xerr1" % (("d" % $$) ^^ (("z" % "d" % $$) ^^ ("z" % "y" % "d" % $$)))) ^^
        (("xc" % "x" % "xin" % "xerr1" % (("d" % $$) ^^ (("z" % "d" % $$) ^^ ("z" % "y" % "d" % $$)))) ^^ $$) ^^
        ("c" % $$))
    )
    abp_send_test
  ).

*)


(* $Id: CSums.v,v 1.13 2003/03/11 13:35:54 lcf Exp $ *)

Require Export CGroups.
Require Export PolyList.
Require Export Peano_dec.

(* Tex_Prose
\chapter{Sums}

\begin{convention}
Let \verb!G! be a group.
\end{convention}
*)

Section Sums.

Variable G : CGroup. (* Sum1 and Sum use subtraction *)

(* Begin_Tex_Verb *)
Fixpoint Sumlist [l:(list G)] : G :=
  Cases l of
    nil => (Zero::G)
  | (cons x k) => x[+](Sumlist k)
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Fixpoint Sumx [n:nat] : ((i:nat)(lt i n)->G)->G :=
  <[n:nat](((i:nat)(lt i n)->G)->G)>
  Cases n of
    O => [_:(i:nat)(lt i O)->G](Zero::G)
  | (S m) => [f:(i:nat)(lt i (S m))->G]
      (Sumx m [i:nat][l:(lt i m)](f i (lt_S ? ? l)))
        [+](f m (lt_n_Sn m))
  end.
(* End_Tex_Verb *)

(* Tex_Prose
It is sometimes useful to view a function defined on $\{0,\ldots,i-1\}$ as a function on the natural numbers which evaluates to $0$ when the input is greater than or equal to $i$.
*)

(* Begin_Tex_Verb *)
Definition part_tot_nat_fun [n:nat][f:(i:nat)(lt i n)->G] : nat->G.
(* End_Tex_Verb *)
Intros n f i.
Elim (le_lt_dec n i).
 Intro a; Apply (Zero::G).
Intro b; Apply (f i b).
Defined.

(* Begin_Tex_Verb *)
Lemma part_tot_nat_fun_ch1 : (n:nat)(f:(i:nat)(lt i n)->G)
  (nat_less_n_fun ?? f)->
  (i:nat)(Hi:(lt i n))(part_tot_nat_fun n f i)[=](f i Hi).
(* End_Tex_Verb *)
Intros n f Hf i Hi.
Unfold part_tot_nat_fun.
Elim le_lt_dec; Intro.
 ElimType False; Apply (le_not_lt n i); Auto.
Simpl; Apply Hf; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma part_tot_nat_fun_ch2 : (n:nat)(f:(i:nat)(lt i n)->G)
  (i:nat)(Hi:(le n i))(part_tot_nat_fun n f i)[=]Zero.
(* End_Tex_Verb *)
Intros n f i Hi.
Unfold part_tot_nat_fun.
Elim le_lt_dec; Intro.
 Simpl; Algebra.
ElimType False; Apply (le_not_lt n i); Auto.
Qed.

(* Begin_Tex_Verb *)
Fixpoint Sum0 [n:nat] : (nat->G)->G := [f:nat->G]
(* Sum i=0..(n-1) *)
  Cases n of
    O => (Zero::G)
  | (S m) => (Sum0 m f)[+](f m)
  end.
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Sum1 : nat->nat->(nat->G)->G :=
(* Sum i=m..(n-1) *)
  [m,n:nat][f:nat->G]((Sum0 n f)[-](Sum0 m f)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Sum : nat->nat->(nat->G)->G :=
(* Sum i=m..n *)
  [m,n:nat](Sum1 m (S n)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Definition Sum2 [m,n:nat][h:(i:nat)(le m i)->(le i n)->G] : G.
(* End_Tex_Verb *)
Intros m n h.
Apply (Sum m n).
Intro i.
Elim (le_lt_dec m i); Intro H.
 Elim (le_lt_dec i n); Intro H0.
  Apply (h i H H0).
 Apply (Zero::G).
Apply (Zero::G).
Defined.

(* Begin_Tex_Verb *)
Lemma Sum_one : (n:nat)(f:nat->G)(Sum n n f)[=](f n).
(* End_Tex_Verb *)
Intros n f.
Unfold Sum.
Unfold Sum1.
Simpl.
Step_final ((f n)[+](Sum0 n f))[-](Sum0 n f).
Qed.

Hints Resolve Sum_one : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_empty : (n:nat)(f:nat->G)(lt O n)->
  (Sum n (pred n) f)[=]Zero.
(* End_Tex_Verb *)
Intros n f H.
Unfold Sum.
Rewrite <- (S_pred ?? H).
Unfold Sum1; Algebra.
Qed.

Hints Resolve Sum_empty : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_Sum : (l,m,n:nat)(f:nat->G)
  (Sum l m f)[+](Sum (S m) n f)[=](Sum l n f).
(* End_Tex_Verb *)
Intros l m n f.
Unfold Sum.
Unfold Sum1.
Step ((Sum0 (S n) f)[-](Sum0 (S m) f))[+]((Sum0 (S m) f)[-](Sum0 l f)).
Step (((Sum0 (S n) f)[-](Sum0 (S m) f))[+](Sum0 (S m) f))[-](Sum0 l f).
Step ((Sum0 (S n) f)[-]((Sum0 (S m) f)[-](Sum0 (S m) f)))[-](Sum0 l f).
Step ((Sum0 (S n) f)[-]Zero)[-](Sum0 l f).
Step ((Sum0 (S n) f)[+][--]Zero)[-](Sum0 l f).
Step_final ((Sum0 (S n) f)[+]Zero)[-](Sum0 l f).
Qed.

Hints Resolve Sum_Sum : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_first : (m,n:nat)(f:nat->G)
  (Sum m n f) [=] (f m)[+](Sum (S m) n f).
(* End_Tex_Verb *)
Intros m n f.
Unfold Sum.
Unfold Sum1.
Step_rht ((f m)[+](Sum0 (S n) f))[-](Sum0 (S m) f).
Step_rht ((Sum0 (S n) f)[+](f m))[-](Sum0 (S m) f).
Step_rht (Sum0 (S n) f)[+]((f m)[-](Sum0 (S m) f)).
Unfold cg_minus.
Apply bin_op_wd_unfolded.
Algebra.
Simpl.
Step_rht (f m)[+][--]((f m)[+](Sum0 m f)).
Step_rht (f m)[+]([--](f m)[+][--](Sum0 m f)).
Step_rht ((f m)[+][--](f m))[+][--](Sum0 m f).
Step_rht Zero[+][--](Sum0 m f).
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_last : (m,n:nat)(f:nat->G)
  (Sum m (S n) f) [=] (Sum m n f)[+](f (S n)).
(* End_Tex_Verb *)
Intros m n f.
Unfold Sum.
Unfold Sum1.
Simpl.
Unfold cg_minus.
Step_lft (Sum0 n f)[+](f n)[+] ((f (S n))[+][--](Sum0 m f)).
Step_rht (Sum0 n f)[+](f n)[+] ([--](Sum0 m f)[+](f (S n))).
Algebra.
Qed.

Hints Resolve Sum_last : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_last' : (m,n:nat)(f:nat->G)(lt O n) ->
  (Sum m n f) [=] (Sum m (pred n) f)[+](f n).
(* End_Tex_Verb *)
Intros m n f H. Induction n.
 Elim (lt_n_n (0) H).
Apply Sum_last.
Qed.

(* Tex_Prose
We add some extensionality results which will be quite useful when working with integration.
*)

(* Begin_Tex_Verb *)
Lemma Sum0_strext :
  (f,g:?)(n:nat)((Sum0 n f)[#](Sum0 n g))->
  {i:nat | (lt i n) & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g n H.
Induction n.
 Simpl in H.
 Elim (ap_irreflexive_unfolded ?? H).
Simpl in H.
Cut {i:nat | (lt i n) & ((f i)[#](g i))}+((f n)[#](g n)).
Intro H0.
Elim H0; Intro H1.
 Elim H1; Intros i H2 H3; Exists i; Auto with arith.
Exists n; Auto with arith.

Cut ((Sum0 n f)[#](Sum0 n g))+((f n)[#](g n)).
Intro H0; Elim H0; Intro H1.
 Left; Apply Hrecn; Assumption.
Auto.

Apply bin_op_strext_unfolded with (!csg_op G).
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_strext : (f,g:?)(m,n:nat)
  (le m (S n))->((Sum m n f)[#](Sum m n g))->
  {i:nat | (le m i)/\(le i n) & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g m n H H0.
Induction n.
 Elim (le_lt_eq_dec ?? H); Intro H2.
  Cut m=O.
  Intro H1.
  Rewrite H1; Exists O; Auto.
  Rewrite H1 in H0.
  Step (Sum O O f); Stepr (Sum O O g); Assumption.

  Inversion H2; [Auto | Inversion H3].
 ElimType False.
 Cut O=(pred (1)); [Intro H3 | Auto].
 Rewrite H3 in H0.
 Rewrite H2 in H0.
 Apply (ap_irreflexive_unfolded G Zero).
 EApply ap_well_def_lft_unfolded.
  EApply ap_well_def_rht_unfolded.
   Apply H0.
  Apply Sum_empty; Auto.
 Apply Sum_empty; Auto.
Elim (le_lt_eq_dec ?? H); Intro Hmn.
 Cut ((Sum m n f)[#](Sum m n g))+((f (S n))[#](g (S n))).
 Intro H1; Elim H1; Intro H2.
  Cut {i:nat | (le m i)/\(le i n) & ((f i)[#](g i))}.
  Intro H3; Elim H3; Intros i H4 H5; Elim H4; Intros H6 H7; Clear H1 H4.
  Exists i; Try Split; Auto with arith.

  Apply Hrecn; Auto with arith.
 Exists (S n); Try Split; Auto with arith.

 Apply bin_op_strext_unfolded with (!csg_op G).
 Step (Sum m (S n) f); Stepr (Sum m (S n) g); Assumption.
Clear Hrecn.
ElimType False.
Cut (S n)=(pred (S (S n))); [Intro H1 | Auto].
Rewrite H1 in H0.
Rewrite Hmn in H0.
Apply (ap_irreflexive_unfolded G Zero).
EApply ap_well_def_lft_unfolded.
 EApply ap_well_def_rht_unfolded.
  Apply H0.
 Apply Sum_empty; Auto with arith.
Apply Sum_empty; Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_strext : (n:nat)(f,g:(i:nat)(lt i n)->G)
  (nat_less_n_fun ?? f)->(nat_less_n_fun ?? g)->
  ((Sumx ? f)[#](Sumx ? g))->
  {N:nat & {HN:(Clt N n) &
    (f N (Clt_to ?? HN))[#](g N (Clt_to ?? HN))}}.
(* End_Tex_Verb *)
Intro n; Induction n.
Intros f g H H0 H1.
Elim (ap_irreflexive_unfolded ?? H1).
Intros f g H H0 H1.
Simpl in H1.
Elim (bin_op_strext_unfolded ?????? H1); Clear H1; Intro H1.
 Cut (nat_less_n_fun ?? [i:nat][l:(lt i n)](f i (lt_S ?? l))); [Intro H2 | Red; Intros; Apply H; Assumption].
 Cut (nat_less_n_fun ?? [i:nat][l:(lt i n)](g i (lt_S ?? l))); [Intro H3 | Red; Intros; Apply H0; Assumption].
 Elim (Hrecn ?? H2 H3 H1); Intros N HN.
 Elim HN; Clear HN; Intros HN H'.
 Exists N.
 Cut (Clt N (S n)); [Intro H4 | Apply toCProp_lt; Apply lt_S; Apply Clt_to; Assumption].
 Exists H4.
 EApply ap_well_def_lft_unfolded.
  EApply ap_well_def_rht_unfolded.
   Apply H'.
  Algebra.
 Algebra.
Exists n.
Exists (toCProp_lt ?? (lt_n_Sn n)).
EApply ap_well_def_lft_unfolded.
 EApply ap_well_def_rht_unfolded.
  Apply H1.
 Algebra.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_strext' : (f,g:?)
  (n:nat)((Sum0 n f)[#](Sum0 n g))->
  {i:nat & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g n H.
Elim (Sum0_strext ??? H); Intros i Hi Hi'; Exists i; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_strext' : (f,g:?)(m,n:nat)
  ((Sum m n f)[#](Sum m n g))->{i:nat & ((f i)[#](g i))}.
(* End_Tex_Verb *)
Intros f g m n H.
Unfold Sum Sum1 in H.
Elim (cg_minus_strext ????? H); Intro H1;
 Elim (Sum0_strext ??? H1);
 Intros i Hi Hi'; Exists i; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_wd : (m:nat)(f,f':nat->G)((i:nat)(f i)[=](f' i)) ->
                (Sum0 m f)[=](Sum0 m f').
(* End_Tex_Verb *)
Intros m f f' H.
Elim m; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_wd : (m,n:nat)(f,f':nat->G)((i:nat)(f i)[=](f' i)) ->
               (Sum m n f)[=](Sum m n f').
(* End_Tex_Verb *)
Intros m n f f' H.
Unfold Sum.
Unfold Sum1.
Unfold cg_minus.
Apply bin_op_wd_unfolded.
 Apply Sum0_wd; Exact H.
Apply un_op_wd_unfolded.
Apply Sum0_wd; Exact H.
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_wd : (n:nat)(f,g:(i:nat)(lt i n)->G)
  ((i:nat)(H:(lt i n))(f i H)[=](g i H))->
  ((Sumx ? f)[=](Sumx ? g)).
(* End_Tex_Verb *)
Intro n; Elim n; Intros; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_wd' :
  (m,n:nat)(le m (S n)) -> (f,f':nat->G)
    ((i:nat)(le m i) -> (le i n) -> ((f i)[=](f' i))) ->
      (Sum m n f)[=](Sum m n f').
(* End_Tex_Verb *)
Intros m n. Induction n; Intros H f f' H0.
 Generalize (toCle ?? H); Clear H; Intro H.
 Inversion H.
  Unfold Sum. Unfold Sum1. Step_final (Zero::G).
 Inversion H2.
 Step (f (0)). Step_rht (f' (0)). Apply H0; Auto.
 Rewrite H3; Auto.
Elim (le_lt_eq_dec m (S (S n)) H); Intro H1.
 Step (Sum m n f)[+](f (S n)).
 Stepr (Sum m n f')[+](f' (S n)).
 Apply bin_op_wd_unfolded; Auto with arith.
Rewrite H1.
Unfold Sum. Unfold Sum1. Step_final (Zero::G).
Qed.

(* Begin_Tex_Verb *)
Lemma Sum2_wd : (m,n:nat)(le m (S n))->
  (f,g:(i:nat)(le m i)->(le i n)->G)
  ((i:nat)(Hm:(le m i))(Hn:(le i n))(f i Hm Hn)[=](g i Hm Hn))->
  (Sum2 ?? f)[=](Sum2 ?? g).
(* End_Tex_Verb *)
Intros m n H f g H0.
Unfold Sum2.
Apply Sum_wd'.
 Assumption.
Intros i H1 H2.
Elim le_lt_dec; Intro H3; [Simpl | ElimType False; Apply (le_not_lt i n); Auto].
Elim le_lt_dec; Intro H4; [Simpl | ElimType False; Apply (le_not_lt m i); Auto].
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_plus_Sum0 : (f,g:nat->G)(m:nat)
                     (Sum0 m [i:nat]((f i)[+](g i))) [=]
                     ((Sum0 m f) [+] (Sum0 m g)).
(* End_Tex_Verb *)
Intros f g m.
Elim m.
 Simpl; Algebra.
Intros n H.
Simpl.
Step (Sum0 n f)[+](Sum0 n g) [+] ((f n)[+](g n)).
Step (Sum0 n f)[+]((Sum0 n g) [+] ((f n)[+](g n))).
Step (Sum0 n f)[+]((Sum0 n g) [+] (f n)[+](g n)).
Step (Sum0 n f)[+]((f n) [+] (Sum0 n g)[+](g n)).
Step (Sum0 n f)[+]((f n) [+] (Sum0 n g))[+](g n).
Step_final (Sum0 n f)[+](f n) [+] (Sum0 n g)[+](g n).
Qed.
Hints Resolve Sum0_plus_Sum0 : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_plus_Sum : (f,g:nat->G)(m,n:nat)
                     (Sum m n [i:nat]((f i)[+](g i))) [=]
                     ((Sum m n f) [+] (Sum m n g)).
(* End_Tex_Verb *)
Intros f g m n.
Unfold Sum.
Unfold Sum1.
Step_lft ((Sum0 (S n) f) [+] (Sum0 (S n) g))[-] ((Sum0 m f) [+](Sum0 m g)).
Step_lft ((((Sum0 (S n) f) [+] (Sum0 (S n) g)) [-] (Sum0 m f)) [-] (Sum0 m g)).
Unfold cg_minus.
Step_rht ((Sum0 (S n) f)[+][--](Sum0 m f)
            [+](Sum0 (S n) g))[+][--](Sum0 m g).
Apply bin_op_wd_unfolded.
 Step_lft (Sum0 (S n) f)[+]((Sum0 (S n) g)[+][--](Sum0 m f)).
 Step_lft (Sum0 (S n) f)[+]([--](Sum0 m f)[+](Sum0 (S n) g)).
 Algebra.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_plus_Sumx : (n:nat)(f,g:(i:nat)(lt i n)->G)
  (Sumx ? f)[+](Sumx ? g)[=]
    (Sumx ? [i:nat][Hi:(lt i n)](f i Hi)[+](g i Hi)).
(* End_Tex_Verb *)
Intro n; Induction n.
 Intros; Simpl; Algebra.
Intros f g; Simpl.
Apply eq_transitive_unfolded with ((Sumx ? [i:nat][l:(lt i n)](f i (lt_S i n l)))[+](Sumx ? [i:nat][l:(lt i n)](g i (lt_S i n l))))[+]
  ((f n (lt_n_Sn n))[+](g n (lt_n_Sn n))).
 LetTac Sf:=(Sumx ? [i:nat][l:(lt i n)](f i (lt_S i n l))).
 LetTac Sg:=(Sumx ? [i:nat][l:(lt i n)](g i (lt_S i n l))).
 LetTac fn:=(f n (lt_n_Sn n)); LetTac gn:=(g n (lt_n_Sn n)).
 Step Sf[+]fn[+]Sg[+]gn.
 Step Sf[+](fn[+]Sg)[+]gn.
 Step Sf[+](Sg[+]fn)[+]gn.
 Step_final Sf[+]Sg[+]fn[+]gn.
Apply bin_op_wd_unfolded; Algebra.
Apply Hrecn with f:=[i:nat][l:(lt i n)](f i (lt_S i n l)) g:=[i:nat][l:(lt i n)](g i (lt_S i n l)).
Qed.

(* Begin_Tex_Verb *)
Lemma Sum2_plus_Sum2 : (m,n:nat)(le m (S n))->
  (f,g:(i:nat)(le m i)->(le i n)->G)
  (Sum2 ?? f)[+](Sum2 ?? g)[=]
    (Sum2 ?? [i,Hm,Hn:?](f i Hm Hn)[+](g i Hm Hn)).
(* End_Tex_Verb *)
Intros m n H f g.
Unfold Sum2; Simpl.
Apply eq_symmetric_unfolded.
EApply eq_transitive_unfolded.
 2: Apply Sum_plus_Sum.
Apply Sum_wd; Intro i.
Elim le_lt_dec; Intro H0; Simpl; Elim le_lt_dec; Intro H1; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma inv_Sum0 : (f:nat->G)(n:nat)
                     (Sum0 n [i:nat]([--](f i))) [=]
                     ([--](Sum0 n f)).
(* End_Tex_Verb *)
Intros f n.
Induction n.
 Simpl; Algebra.
Simpl.
Step_final ([--](Sum0 n f)) [+] ([--](f n)).
Qed.

Hints Resolve inv_Sum0 : algebra.

(* Begin_Tex_Verb *)
Lemma inv_Sum : (f:nat->G)(m,n:nat)
                     (Sum m n [i:nat]([--](f i))) [=]
                     ([--](Sum m n f)).
(* End_Tex_Verb *)
Intros f a b.
Unfold Sum.
Unfold Sum1.
Step ([--](Sum0 (S b) f)) [-] ([--](Sum0 a f)).
Step ([--](Sum0 (S b) f)) [+] [--] ([--](Sum0 a f)).
Step_final [--]((Sum0 (S b) f) [+] ([--](Sum0 a f))).
Qed.

Hints Resolve inv_Sum : algebra.

(* Begin_Tex_Verb *)
Lemma inv_Sumx : (n:nat)(f:(i:nat)(lt i n)->G)
  [--](Sumx ? f)[=](Sumx ? [i:nat][Hi:(lt i n)][--](f i Hi)).
(* End_Tex_Verb *)
Intro n; Induction n.
 Simpl; Algebra.
Intro f; Simpl.
Step ([--](Sumx ? [i:nat][l:(lt i n)](f i (lt_S i n l))))[+]([--](f n (lt_n_Sn n))).
Apply bin_op_wd_unfolded.
 Apply Hrecn with f:=[i:nat][l:(lt i n)](f i (lt_S i n l)).
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma inv_Sum2 : (m,n:nat)(le m (S n))->
  (f:(i:nat)(le m i)->(le i n)->G)
  [--](Sum2 ?? f)[=](Sum2 ?? [i,Hm,Hn:?][--](f i Hm Hn)).
(* End_Tex_Verb *)
Intros m n H f.
Unfold Sum2; Simpl.
Apply eq_symmetric_unfolded.
EApply eq_transitive_unfolded.
 2: Apply inv_Sum.
Apply Sum_wd; Intro i.
Elim le_lt_dec; Intro; Simpl; Elim le_lt_dec; Intro; Simpl; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_minus_Sum : (f,g:nat->G)(m,n:nat)
                      (Sum m n [i:nat]((f i)[-](g i))) [=]
                      ((Sum m n f) [-] (Sum m n g)).
(* End_Tex_Verb *)
(* WHAT A MISERY TO PROVE THIS *)
Intros f g a b.
Step (Sum a b [i:nat]((f i)[+] ([--](g i)))).
Cut (Sum a b [i:nat]((f i)[+]( ([j:nat]([--](g j))) i))) [=]
    (Sum a b f)[+](Sum a b [j:nat]([--](g j))).
Intro H.
Step (Sum a b f)[+](Sum a b [j:nat]([--](g j))).
Step_final ((Sum a b f) [+][--] (Sum a b g)).

Change (Sum a b [i:nat]((f i)[+]( ([j:nat]([--](g j))) i))) [=]
       (Sum a b f)[+](Sum a b [j:nat]([--](g j))).
Apply Sum_plus_Sum.
Qed.

Hints Resolve Sum_minus_Sum : algebra.

(* Begin_Tex_Verb *)
Lemma Sumx_minus_Sumx : (n:nat)(f,g:(i:nat)(lt i n)->G)
  (Sumx ? f)[-](Sumx ? g)[=](Sumx ? [i,Hi:?](f i Hi)[-](g i Hi)).
(* End_Tex_Verb *)
Intros n f g; Unfold cg_minus.
EApply eq_transitive_unfolded.
 2: Apply Sumx_plus_Sumx with f:=f g:=[i:nat][Hi:(lt i n)][--](g i Hi).
Apply bin_op_wd_unfolded; Algebra.
Apply inv_Sumx.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum2_minus_Sum2 : (m,n:nat)(le m (S n))->
  (f,g:(i:nat)(le m i)->(le i n)->G)
  (Sum2 ?? f)[-](Sum2 ?? g)[=]
    (Sum2 ?? [i,Hm,Hn:?](f i Hm Hn)[-](g i Hm Hn)).
(* End_Tex_Verb *)
Intros m n H f g; Unfold cg_minus.
EApply eq_transitive_unfolded.
 2: Apply Sum2_plus_Sum2 with f:=f g:=[i:nat][Hm:(le m i)][Hn:(le i n)][--](g i Hm Hn); Assumption.
Apply bin_op_wd_unfolded.
 Algebra.
Apply inv_Sum2; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_apzero : (f:nat->G)(m,n:nat)(le m n) ->
  ((Sum m n f) [#] Zero) ->
    {i:nat | (le m i)/\(le i n) & ((f i) [#] Zero)}.
(* End_Tex_Verb *)
Intros a k l H H0. Induction l.
 Exists (0). Split; Auto. Cut k=O.
 Intro H'. Rewrite H' in H0.
 Step (Sum (0) (0) a).
 Inversion H. Auto.
Elim (le_lt_eq_dec k (S l) H); Intro HH.
Cut ((Sum k l a) [#] Zero) + ((a (S l)) [#] Zero). Intro H1.
Elim H1; Clear H1; Intro H1.
 Elim Hrecl; Auto with arith.
 Intro i. Intros H2 H6. Exists i; Auto.
 Elim H2; Intros H3 H4; Auto.
Exists (S l); Try Split; Auto with arith.

Apply cg_add_ap_zero.
Apply ap_well_def_lft_unfolded with (Sum k (S l) a). Auto.
Apply Sum_last.

Rewrite HH in H0.
Exists (S l); Auto.
Step (Sum (S l) (S l) a).
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_zero : (f:nat->G)(m,n:nat)(le m (S n)) ->
  ((i:nat)(le m i) -> (le i n) -> (f i) [=] Zero) ->
    (Sum m n f) [=] Zero.
(* End_Tex_Verb *)
Intros a k l H H0. Induction l.
 Elim (le_lt_eq_dec ?? H); Clear H; Intro H.
  Replace k with O. Step (a O). Apply H0. Auto.
  Auto with arith. Auto. Inversion H. Auto. Inversion H2.
 Rewrite H.
 Unfold Sum. Unfold Sum1. Algebra.
Elim (le_lt_eq_dec k (S (S l)) H); Intro HH.
 Step (Sum k l a)[+](a (S l)).
 Stepr Zero[+](Zero::G).
 Apply bin_op_wd_unfolded.
  Apply Hrecl; Auto with arith.
 Apply H0; Auto with arith.
Rewrite HH.
Unfold Sum. Unfold Sum1. Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum_term : (f:nat->G)(m,i,n:nat)(le m i) -> (le i n) ->
  ((j:nat)(le m j) -> (~j=i) -> (le j n) -> (f j) [=] Zero) ->
    (Sum m n f) [=] (f i).
(* End_Tex_Verb *)
Intros a k i0 l H H0 H1.
Step (Sum k i0 a)[+](Sum (S i0) l a).
Stepr (a i0)[+]Zero.
Apply bin_op_wd_unfolded.
 Elim (O_or_S i0); Intro H2.
  Elim H2; Intros m Hm.
  Rewrite <- Hm.
  Step (Sum k m a)[+](a (S m)).
  Stepr Zero[+](a (S m)).
  Apply bin_op_wd_unfolded.
   Apply Sum_zero. Rewrite Hm; Auto.
   Intros i H3 H4. Apply H1. Auto. Omega. Omega.
  Algebra.
 Rewrite <- H2 in H. Rewrite <- H2.
 Generalize (toCle ?? H); Clear H; Intro H.
 Inversion H. Algebra.
Apply Sum_zero. Auto with arith.
Intros. Apply H1. Omega. Omega. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Sum0_shift : (f,g:nat->G)(n:nat)
  ((i:nat)((f i) [=] (g (S i)))) ->
    (g (0))[+](Sum0 n f) [=] (Sum0 (S n) g).
(* End_Tex_Verb *)
Intros a b l H. Induction l.
 Simpl; Algebra.
Simpl.
Step (b (0))[+](Sum0 l a)[+](a l).
Step_final (Sum0 (S l) b)[+](a l).
Qed.

Hints Resolve Sum0_shift : algebra.

(* Begin_Tex_Verb *)
Lemma Sum_shift : (f,g:nat->G)(m,n:nat)
  ((i:nat)((f i) [=] (g (S i)))) ->
    (Sum m n f) [=] (Sum (S m) (S n) g).
(* End_Tex_Verb *)
Unfold Sum. Unfold Sum1. Intros a b k l H.
Step (((Sum0 (S l) a)[+](b (0)))[-](b (0)))[-](Sum0 k a).
Step ((Sum0 (S l) a)[+](b (0)))[-]((b (0))[+](Sum0 k a)).
Step_final ((b (0))[+](Sum0 (S l) a))[-]((b (0))[+](Sum0 k a)).
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_Sum0 : (n,f,g:?)((i:nat)(Hi:(lt i n))
  (f i Hi)[=](g i))->(Sumx n f)[=](Sum0 n g).
(* End_Tex_Verb *)
Intro; Induction n; Simpl; Algebra.
Qed.

End Sums.

Implicits Sum [1].
Implicits Sum0 [1].
Implicits Sumx [1 2].
Implicits Sum2 [1 2 3].

Section More_Sums.

Variable G:CGroup.

(* Tex_Prose
The next results are useful for calculating some special Sums, often referred to as ``Mengolli Sums''.
*)

(* Begin_Tex_Verb *)
Lemma Mengolli_Sum : (n:nat)(f:(i:nat)(le i n)->G)
  (g:(i:nat)(lt i n)->G)(nat_less_n_fun' ?? f)->
  ((i:nat)(H:(lt i n))
    ((g i H)[=](f (S i) H)[-](f i (lt_le_weak ?? H))))->
  (Sumx g)[=]((f n (le_n n))[-](f O (le_O_n n))).
(* End_Tex_Verb *)
Intro n; Induction n; Intros f g Hf H; Simpl.
 Step (f O (le_n O))[-](f O (le_n O)).
 Apply cg_minus_wd; Algebra.
Apply eq_transitive_unfolded with ((f ? (le_n (S n)))[-](f ? (le_S ?? (le_n n))))[+]((f ? (le_S ?? (le_n n)))[-](f O (le_O_n (S n)))).
 EApply eq_transitive_unfolded.
  Apply cm_commutes_unfolded.
 Apply bin_op_wd_unfolded.
  EApply eq_transitive_unfolded.
   Apply H.
  Apply cg_minus_wd; Apply Hf; Algebra.
 LetTac f':=[i:nat][H:(le i n)](f i (le_S ?? H)).
 LetTac g':=[i:nat][H:(lt i n)](g i (lt_S ?? H)).
 Apply eq_transitive_unfolded with (f' n (le_n n))[-](f' O (le_O_n n)).
  Apply Hrecn.
   Red; Intros; Unfold f'; Apply Hf; Algebra.
  Intros i Hi.
  Unfold f'; Unfold g'.
  EApply eq_transitive_unfolded.
   Apply H.
  Apply cg_minus_wd; Apply Hf; Algebra.
 Unfold f'; Apply cg_minus_wd; Apply Hf; Algebra.
Stepr ((f (S n) (le_n (S n)))[+]Zero)[-](f O (le_O_n (S n))).
Stepr ((f (S n) (le_n (S n)))[+]([--](f n (le_S ?? (le_n n)))[+](f n (le_S ?? (le_n n)))))[-](f O (le_O_n (S n))).
Step_final (((f (S n) (le_n (S n)))[+][--](f n (le_S ?? (le_n n))))[+](f n (le_S ?? (le_n n))))[-](f O (le_O_n (S n))).
Qed.

(* Begin_Tex_Verb *)
Lemma Mengolli_Sum_gen : (f,g:nat->G)
  ((n:nat)(g n)[=]((f (S n))[-](f n)))->
  (m,n:nat)(le m (S n))->(Sum m n g)[=]((f (S n))[-](f m)).
(* End_Tex_Verb *)
Intros f g H m n; Induction n; Intro Hmn.
 Elim (le_lt_eq_dec ?? Hmn); Intro H0.
  Cut m=O; [Intro H1 | Inversion H0; Auto with arith; Inversion H2].
  Rewrite H1.
  EApply eq_transitive_unfolded; [Apply Sum_one | Apply H].
 Cut O=(pred (1)); [Intro H1 | Auto].
 Rewrite H0; Stepr (Zero::G); Rewrite H1; Apply Sum_empty.
 Auto with arith.
Simpl in Hmn; Elim (le_lt_eq_dec ?? Hmn); Intro H0.
 Apply eq_transitive_unfolded with ((f (S (S n)))[-](f (S n)))[+]((f (S n))[-](f m)).
  EApply eq_transitive_unfolded.
   Apply Sum_last.
  EApply eq_transitive_unfolded.
   Apply cm_commutes_unfolded.
  Apply bin_op_wd_unfolded; [Apply H | Apply Hrecn].
  Auto with arith.
 Stepr ((f (S (S n)))[+]Zero)[-](f m).
 Stepr ((f (S (S n)))[+]([--](f (S n))[+](f (S n))))[-](f m).
 Step_final (((f (S (S n)))[+][--](f (S n)))[+](f (S n)))[-](f m).
Rewrite H0.
Stepr (Zero::G).
Cut (S n)=(pred (S (S n))); [Intro H2 | Auto].
Rewrite H2; Apply Sum_empty.
Auto with arith.
Qed.

(* Begin_Tex_Verb *)
Lemma str_Mengolli_Sum_gen : (f,g:nat->G)(m,n:nat)(le m (S n))->
  ((i:nat)(le m i)->(le i n)->(g i)[=]((f (S i))[-](f i)))->
  (Sum m n g)[=]((f (S n))[-](f m)).
(* End_Tex_Verb *)
Intros f g m n H H0.
Apply eq_transitive_unfolded with (Sum m n [i:nat](f (S i))[-](f i)).
 Apply Sum_wd'; Assumption.
Apply Mengolli_Sum_gen; [Intro; Algebra | Assumption].
Qed.

(* Begin_Tex_Verb *)
Lemma Sumx_to_Sum : (n:nat)(lt O n)->(f:(i:nat)(lt i n)->G)
  (nat_less_n_fun ?? f)->
  (Sumx f)[=](Sum O (pred n) (part_tot_nat_fun ?? f)).
(* End_Tex_Verb *)
Intro n; Induction n; Intros H f Hf.
ElimType False; Inversion H.
Cut (le O n); [Intro H0 | Auto with arith].
Elim (le_lt_eq_dec ?? H0); Clear H H0; Intro H.
 Simpl.
 Pattern 6 n; Rewrite (S_pred ?? H).
 EApply eq_transitive_unfolded.
  2: Apply eq_symmetric_unfolded; Apply Sum_last.
 Apply bin_op_wd_unfolded.
  EApply eq_transitive_unfolded.
   Apply Hrecn; Auto.
   Red; Intros; Apply Hf; Auto.
  Apply Sum_wd'.
   Auto with arith.
  Intros i H1 H2.
  Cut (lt i n); [Intro | Omega].
  EApply eq_transitive_unfolded.
   Apply part_tot_nat_fun_ch1 with Hi:=H0.
   Red; Intros; Apply Hf; Auto.
  Apply eq_symmetric_unfolded.
  EApply eq_transitive_unfolded.
   Apply part_tot_nat_fun_ch1 with Hi:=(lt_S ?? H0).
   Red; Intros; Apply Hf; Auto.
  Algebra.
 Rewrite <- (S_pred ?? H).
Apply eq_symmetric_unfolded; Apply part_tot_nat_fun_ch1; Auto.
Generalize f Hf; Clear Hf f; Rewrite <- H.
Simpl; Intros f Hf.
EApply eq_transitive_unfolded.
 2: Apply eq_symmetric_unfolded; Apply Sum_one.
Step (f O (lt_n_Sn O)).
Apply eq_symmetric_unfolded; Apply part_tot_nat_fun_ch1; Auto.
Qed.

End More_Sums.

Hints Resolve Sum_one Sum_Sum Sum_first Sum_last Sum_last' Sum_wd
  Sum_plus_Sum: algebra.
Hints Resolve Sum_minus_Sum inv_Sum inv_Sum0 : algebra.


Require Export D.

(** **** Exercise: 4 stars (hoare_asgn_wrong)  *)
(** The assignment rule looks backward to almost everyone the first
    time they see it.  If it still seems backward to you, it may help
    to think a little about alternative "forward" rules.  Here is a
    seemingly natural one:
      ------------------------------ (hoare_asgn_wrong)
      {{ True }} X ::= a {{ X = a }}
    Give a counterexample showing that this rule is incorrect
    (informally). Hint: The rule universally quantifies over the
    arithmetic expression [a], and your counterexample needs to
    exhibit an [a] for which the rule doesn't work. *)

Theorem hoare_asgn_wrong:
  exists a, ~ {{ fun st => True }} X ::= a {{ fun st => st X = aeval st a}}.
Proof.
  exists (APlus (AId X) (ANum 1)). unfold not. intros Hcontra.
  simpl in Hcontra. unfold hoare_triple in Hcontra.
  assert ((t_update empty_state X 1) X = (t_update empty_state X 1) X + 1).
  { eapply Hcontra. apply E_Ass. reflexivity. reflexivity. }
  simpl in H. inversion H.
Qed.


Require Export SystemFR.Syntax.

Require Export SystemFR.Tactics.
Require Export SystemFR.ListSetLemmas.
Require Export SystemFR.AssocList.
Require Export SystemFR.ListUtils.
Require Export SystemFR.EqualWithRelation.
Require Export SystemFR.EquivalentWithRelation.

Require Import PeanoNat.

Open Scope list_scope.

Fixpoint idrel (l: list nat) :=
  match l with
  | nil => nil
  | x :: xs => (x,x) :: idrel xs
  end.

Lemma idrel_lookup:
  forall l x,
    x ∈ l ->
    lookup PeanoNat.Nat.eq_dec (idrel l) x = Some x.
Proof.
  induction l; steps.
Qed.

Lemma idrel_lookup_swap:
  forall l x,
    x ∈ l ->
    lookup PeanoNat.Nat.eq_dec (swap (idrel l)) x = Some x.
Proof.
  induction l; steps.
Qed.

Lemma equal_with_idrel:
  forall t, equal_with_relation type_var (idrel (pfv t type_var)) t t.
Proof.
  intros; apply equal_with_relation_refl2; steps;
    eauto using idrel_lookup, idrel_lookup_swap.
Qed.

Lemma idrel_lookup_fail:
  forall l x,
    (x ∈ l -> False) ->
    lookup PeanoNat.Nat.eq_dec (idrel l) x = None.
Proof.
  induction l; steps.
Qed.

Lemma idrel_lookup_swap_fail:
  forall l x,
    (x ∈ l -> False) ->
    lookup PeanoNat.Nat.eq_dec (swap (idrel l)) x = None.
Proof.
  induction l; steps.
Qed.

Lemma support_idrel:
  forall l, support (idrel l) = l.
Proof.
  induction l; steps.
Qed.

Lemma range_idrel:
  forall l, range (idrel l) = l.
Proof.
  induction l; steps.
Qed.

Lemma support_swap:
  forall l, support (swap l) = range l.
Proof.
  induction l; steps.
Qed.

Lemma range_swap:
  forall l, range (swap l) = support l.
Proof.
  induction l; steps.
Qed.

Lemma equivalent_rc_refl:
  forall rc, equivalent_rc rc rc.
Proof.
  unfold equivalent_rc; steps.
Qed.

Lemma equivalent_with_idrel:
  forall T (l: list nat) (x: nat) ρ t (equiv: T -> T -> Prop),
    (x ∈ l -> False) ->
    (forall v, equiv v v) ->
    equivalent_with_relation (idrel l) ρ ((x,t) :: ρ) equiv.
Proof.
  unfold equivalent_with_relation;
    repeat step || t_lookup ||
           rewrite support_idrel in * ||
           rewrite support_swap in * ||
           rewrite range_idrel in * ||
           rewrite range_swap in * ||
           (rewrite idrel_lookup in * by auto) ||
           (rewrite idrel_lookup_swap_fail in * by auto) ||
           apply equivalent_with_right.
Qed.

Lemma equivalent_with_idrel2:
  forall T (l: list nat) (x: nat) ρ t (equiv: T -> T -> Prop),
    (x ∈ l -> False) ->
    (forall v, equiv v v) ->
    equivalent_with_relation (idrel l) ((x,t) :: ρ) ρ equiv.
Proof.
  unfold equivalent_with_relation;
    repeat step || t_lookup ||
           rewrite support_idrel in * ||
           rewrite support_swap in * ||
           rewrite range_idrel in * ||
           rewrite range_swap in * ||
           (rewrite idrel_lookup in * by auto) ||
           (rewrite idrel_lookup_swap_fail in * by auto) ||
           apply equivalent_with_left.
Qed.

Ltac t_idrel :=
  rewrite support_idrel in * ||
  rewrite support_swap in * ||
  rewrite range_idrel in * ||
  rewrite range_swap in * ||
  (rewrite idrel_lookup in * by auto) ||
  (rewrite idrel_lookup_swap_fail in * by auto).

Lemma equivalent_with_relation_permute:
  forall T ρ1 ρ2 v M l (equiv: T -> T -> Prop),
    ~(M ∈ support ρ1) ->
    (forall v, equiv v v) ->
    equivalent_with_relation
      ((M, M) :: idrel l)
      (ρ1 ++ (M, v) :: ρ2)
      ((M, v) :: ρ1 ++ ρ2)
      equiv
.
Proof.
  unfold equivalent_with_relation, equivalent_with;
    repeat match goal with
           | |- exists r, Some ?R = Some r /\ _ => exists R
           | |- exists r, _ /\ equivalent_rc r ?R => exists R
           | H: _ |- _ => rewrite lookup_remove2 in H by steps
           | _ => rewrite lookup_remove2 by steps
           | _ => step || t_lookup_rewrite || t_idrel || t_lookup || list_utils ||
                 rewrite obvious_lookup in * by steps ||
                 t_lookupor || t_lookup_same
           end;
    eauto.
Qed.

Lemma idrel_lookup2:
  forall x y l eq_dec, lookup eq_dec (idrel l) x = Some y -> x = y /\ x ∈ l.
Proof.
  induction l; repeat step || eapply_any || instantiate_any.
Qed.

Ltac t_idrel_lookup2 :=
  match goal with
  | H: lookup _ (idrel ?l) ?x = Some ?y |- _ => pose proof (idrel_lookup2 _ _ _ _ H); clear H
  end.

Lemma swap_idrel:
  forall l, swap (idrel l) = idrel l.
Proof.
  induction l; steps.
Qed.

Lemma equivalent_with_relation_permute2:
  forall T ρ1 ρ2 v X Y l (equiv: T -> T -> Prop),
    ~(X ∈ support ρ1) ->
    (forall v, equiv v v) ->
    equivalent_with_relation
      ((Y, X) :: idrel l)
      ((Y, v) :: ρ1 ++ ρ2)
      (ρ1 ++ (X, v) :: ρ2)
      equiv
.
Proof.
  unfold equivalent_with_relation, equivalent_with;
    repeat match goal with
           | |- exists r, Some ?R = Some r /\ _ => exists R
           | |- exists r, _ /\ equivalent_rc r ?R => exists R
           | H: _ |- _ => rewrite lookup_remove2 in H by steps
           | _ => rewrite lookup_remove2 by steps
           | _ => step || t_lookup_rewrite || t_idrel || t_lookup || list_utils ||
                 rewrite obvious_lookup in * by steps ||
                 t_lookupor || t_lookup_same
           end;
    eauto.
Qed.


Require Import
  Coq.Classes.CMorphisms
  Coq.Classes.CRelationClasses
  Pattern.StdLib.

Set Universe Polymorphism.
Generalizable All Variables.

Definition prod_op {A B} (fA : crelation A) (fB : crelation B)
   (x y : A * B) := (fA (fst x) (fst y) * fB (snd x) (snd y))%type.

Definition map_op {A B}
  (f : A -> B) (P : crelation B) (x y : A) : Type :=
  P (f x) (f y).

Definition pointwise_op {A} {B : A -> Type}
  (P : forall a, crelation (B a))
  (f g : forall a, B a) := forall a, P a (f a) (g a).

(** A tour of algebraic structures. Most of them are things related to
    orders or latices.
    Each definition follows a relatively rigid pattern.
    Each algebraic structure is defined in its own module.
    For instance, preorders are defined in the Module [PreO].
    The type which defines the algebraic structure for preorders
    is called [t], which outside the module looks like [PreO.t].

    Let's be concrete. The type [Qnn] of non-negative rational numbers
    has a relation [Qnnle : Qnn -> Qnn -> Prop] which represents a
    preorder. Therefore, we can make an instance
    [H : PO.t Qnn Qnnle] which gives evidence that [Qnnle] is in fact
    a preorder.

    Within the module [PreO] (and for most algebraic structures), we have a
    type [morph] which gives evidence that some function in fact is a morphism
    in that category of algebraic structure; that is, it preserves the structure
    for whatever algebraic structure we defined. We always prove that the identity
    function is a morphism [morph_id] and that morphisms are closed under
    composition [morph_compose].

    At the end we give examples or building blocks for the algebraic structure.
    There's usually trivial examples of these structures over base types which
    have only one or two elements. There is usually a way to form products,
    and often, given an algebraic structure on [B] and a function [f : A -> B],
    we can define the algebraic structure on [A] by asking whether it holds
    pointwise in [B].

    Just given a preorder, we can define what it means for something to be
    a top element or bottom, max or min, infimum or supremum, and so these
    definitions are given in the [PO] module. Many algebraic structures are
    then closed under these operations, in which case there will be functions
    that are defined that implement the given operation. For instance, for
    meet-semilattices, we have an operation for minimums.
*)

(** Preorders: types which have a "<=" relation which is reflexitive and
    transitive *)
Module PreO.
  (** The relation [le] (read: Less than or Equal) is a preorder when
      it is reflexive [le_refl] and transitive [le_trans]. *)
  Class t {A : Type} {le : crelation A} : Type :=
    { le_refl : forall x, le x x
    ; le_trans : forall x y z, le x y -> le y z -> le x z
    }.

  Arguments t {A} le : clear implicits.

  Instance PreOrder_I `{tle : t A leA} : PreOrder leA.
  Proof.
  constructor.
  - unfold Reflexive. apply le_refl.
  - unfold Transitive. apply le_trans.
  Qed.

  (** A morphism of preorders is just a monotonic function. That is,
      it preserves ordering. *)
  Definition morph `(leA : crelation A) `(leB : crelation B)
   `(f : A -> B) : Type :=
    forall a b, leA a b -> leB (f a) (f b).

  Section Facts.

  Context `{le : crelation A}.
  Context (tA : t le).
  Infix "<=" := le.

  Lemma morph_id : morph le le (fun x => x).
  Proof.
    unfold morph; auto.
  Qed.

  Lemma morph_compose `(tB : t B leB) `(tC : t C leC)
    : forall (f : A -> B) (g : B -> C),
     morph le leB f -> morph leB leC g -> morph le leC (fun x => g (f x)).
  Proof.
    unfold morph; auto.
  Qed.

  (** [top t] holds if [t] is bigger than everything *)
  Definition top (t : A) : Type := forall a, a <= t.

  (** [bottom b] holds if [b] is smaller than everything *)
  Definition bottom (b : A) : Type := forall a, b <= a.

  (** [max l r m] holds if [m] is the maximum of [l] and [r]. *)
  Record max {l r m : A} : Type :=
  { max_l     : l <= m
  ; max_r     : r <= m
  ; max_least : forall m', l <= m' -> r <= m' -> m <= m'
  }.

  Arguments max : clear implicits.

  (** [max] is commutative *)
  Lemma max_comm : forall l r m, max l r m -> max r l m.
  Proof.
  intros. destruct X; constructor; auto.
  Qed.

  (** [min l r m] holds if [m] is the minimum of [l] and [r] *)
  Record min {l r m : A} : Type :=
  { min_l        : m <= l
  ; min_r        : m <= r
  ; min_greatest : forall m', m' <= l -> m' <= r -> m' <= m
  }.

  Global Arguments min : clear implicits.

  (** [min] is commutative *)
  Lemma min_comm : forall l r m, min l r m -> min r l m.
  Proof.
  intros. destruct X; constructor; auto.
  Qed.

  Require Coq.Setoids.Setoid.

  (** [min] is associative, phrased in a relational manner,
      i.e., minima are associative when they exist *)
  Lemma min_assoc : forall a b c,
    forall bc, min b c bc ->
    forall ab, min a b ab ->
    forall abc, iffT (min a bc abc) (min ab c abc).
  Proof.
  intros a b c bc BC ab AB abc. split; intros ABC.
  - constructor.
    + apply (min_greatest AB).
      * apply (min_l ABC).
      * rewrite (min_r ABC). apply (min_l BC).
    + rewrite (min_r ABC). apply (min_r BC).
    + intros m' H H0. apply (min_greatest ABC).
      * rewrite H. apply (min_l AB).
      * apply (min_greatest BC).  rewrite H. apply (min_r AB).
        assumption.
  - constructor.
    + rewrite (min_l ABC). apply (min_l AB).
    + apply (min_greatest BC).
      * rewrite (min_l ABC). apply (min_r AB).
      * apply (min_r ABC).
    + intros m' H H0. apply (min_greatest ABC).
      * apply (min_greatest AB).
        assumption. rewrite H0. apply (min_l BC).
      * rewrite H0. apply (min_r BC).
  Qed.

  Lemma min_idempotent : forall a, min a a a.
  Proof.
  intros. constructor.
  - reflexivity.
  - reflexivity.
  - intros. assumption.
  Qed.

  (** [sup f m] holds when [m] is the supremum of all
      values indexed by [f]. *)
  Record sup {I : Type} (f : I -> A) (m : A) : Type :=
  { sup_ge : forall i, f i <= m
  ; sup_least : forall m', (forall i, f i <= m') -> m <= m'
  }.

  (** [inf f m] holds when [m] is the infimum of all
      values indexed by [f]. *)
  Record inf {I : Type} (f : I -> A) (m : A) : Type :=
  { inf_le : forall i, m <= f i
  ; inf_greatest : forall m', (forall i, m' <= f i) -> m' <= m
  }.

  (** A directed subset of [A] is one where every two
      elements have a common upper bound. *)
  Definition directed {I} (f : I -> A) :=
    forall i j : I, { k : A & prod (f i <= k) (f j <= k) }.

  End Facts.

  Definition scott_cont `{tA : t A leA}
  `{tB : t B leB} (f : A -> B) :=
  forall I (g : I -> A), @directed _ leA _ g
  -> forall m, @sup _ leA _ g m
  -> @sup _ leB _ (fun i => f (g i)) (f m).

  (** [True], the one-element type, has a trivial preorder *)
  Definition one : t (fun (_ : True) _ => True).
  Proof. constructor; auto.
  Qed.

  Require Bool.Bool.

  (** The preorder on booleans given by False < True *)
  Definition two : t Bool.leb.
  Proof. constructor.
  - intros; auto. destruct x; simpl; trivial.
  - destruct x, y, z; auto. simpl in *. congruence.
  Qed.

  Require Coq.Arith.Le.
  Definition Nat : t le.
  Proof. constructor; [ apply Le.le_refl | apply Le.le_trans ].
  Qed.

  Definition discrete (A : Type) : t (@Logic.eq A).
  Proof. constructor; auto. intros; subst; auto. Qed.

  (** Product preorders *)
  Definition product `(tA : t A leA) `(tB : t B leB)
   : t (prod_op leA leB).
  Proof. constructor.
   - destruct x. split; apply le_refl.
   - unfold prod_op; intros x y z H H0.
     destruct x, y, z; simpl in *.
     destruct H, H0.
     split; etransitivity; eassumption.
  Qed.

  (** Given a preorder on [B] and a function [f : A -> B],
      we form a preorder on [A] by asking about their order
      when mapped into [B] by [f]. *)
  Definition map `(f : A -> B) `(tB : t B leB)
    : t (fun x y => leB (f x) (f y)).
  Proof. constructor; intros.
  - apply le_refl.
  - eapply le_trans; eauto.
  Qed.

  (** It's probably easiest to explain the simply-typed
      version of this: Given a preorder on [B], we can
      form a preorder on functions of type [A -> B] by saying
      [f <= g] (where [f, g : A -> B]) whenever
      the relation holds pointwise, i.e., for all [a : A],
      we have [f a <= g a]. *)
  Definition pointwise {A} {B : A -> Type}
    {leB : forall a, B a -> B a -> Type}
    (tB : forall a, t (leB a))
    : @t (forall a, B a) (pointwise_op leB).
  Proof.
    unfold pointwise_op; constructor; intros.
    - apply le_refl.
    - eapply le_trans; eauto.
  Qed.

  Definition morph_pointwise {A B C} `{tC : t C leC} (f : B -> A)
    : morph (pointwise_op (fun _ => leC)) (pointwise_op (fun _ => leC))
      (fun g b => g (f b)).
  Proof.
    unfold morph, pointwise_op. intros a b H a'; simpl in *; apply H.
  Qed.

  (** The type of propositions forms a preorder, where "<=" is
      implication. *)
  Local Instance prop : t (fun (P Q : Prop) => P -> Q).
  Proof.
    constructor; auto.
  Qed.

  Local Instance type : t arrow.
  Proof.
    constructor; intros.
     - exact (fun x => x).
     - exact (fun x => X0 (X x)).
  Defined.

  (** Subsets, in type theory defined as propositional functions,
      i.e., subsets on [A] are functions of type [f : A -> Prop],
      form a preorder ordered by subset inclusion. This is actually just
      the preorder on propositions applied pointwise to functions. *)
  Require Import Pattern.SetsC.

  Local Instance subset (A : Type) : @t (Subset A) _ := pointwise (fun _ => type).

End PreO.

Arguments PreO.max {A} {le} _ _ _ : clear implicits.

(** Partial orders: We take a preorder, but also have an equality relation [eq]
    such that [eq x y] exactly when both [le x y] and [le y x]. *)
Module PO.

Section PO.
Universes UA UP.

  Class t {A : Type@{UA}} {le eq : crelation@{UA UP} A} : Type@{UP} :=
  { PreO :> PreO.t le
  ; le_proper : Proper (eq ==> eq ==> iffT) le
  ; le_antisym : forall x y, le x y -> le y x -> eq x y
  }.

  Arguments t {A} le eq : clear implicits.

  Section Morph.
  Context {A : Type@{UA}} {leA eqA : crelation@{UA UP} A} {tA : t leA eqA}
          {B : Type@{UA}} {leB eqB : crelation@{UA UP} B} {tB : t leB eqB}.

  Record morph {f : A -> B} : Type@{UP} :=
   { f_PreO : PreO.morph leA leB f
   ; f_eq : Proper (eqA ==> eqB) f
   }.

  Arguments morph : clear implicits.

  End Morph.

  Arguments morph {_} leA eqA {_} leB eqB f.

  Section Facts.
  Context {A : Type@{UA}} {leA eqA : crelation@{UA UP} A} {tA : t leA eqA}.

  (** The equality relation of a partial order must form an
      equivalence relation. *)
  Definition eq_refl : Reflexive eqA.
  Proof. unfold Reflexive.
    intros. apply le_antisym; apply PreO.le_refl.
  Qed.

  Definition eq_sym : Symmetric eqA.
  Proof.
  unfold Symmetric. intros x y H. apply le_antisym. eapply le_proper.
  apply eq_refl. apply H. apply PreO.le_refl. eapply le_proper.
  apply H. apply eq_refl. apply PreO.le_refl.
  Qed.

  Definition eq_trans : Transitive eqA.
  Proof.
    unfold Transitive.
    intros x y z H H0. apply le_antisym. eapply le_proper. apply H.
    apply eq_refl. eapply le_proper. apply H0. apply eq_refl.
    apply PreO.le_refl. eapply le_proper. apply eq_refl. apply H.
    eapply le_proper. apply eq_refl. apply H0. apply PreO.le_refl.
  Qed.

  Lemma max_unique : forall l r m m'
   , PreO.max (le := leA) l r m
   -> PreO.max (le := leA) l r m'
   -> eqA m m'.
  Proof.
  intros l r m m' H H0. apply PO.le_antisym.
  - apply H; apply H0.
  - apply H0; apply H.
  Qed.

  Lemma min_unique : forall l r m m'
   , PreO.min (le := leA) l r m
   -> PreO.min (le := leA) l r m'
   -> eqA m m'.
  Proof.
  intros l r m m' H H0. apply PO.le_antisym.
  - apply H0; apply H.
  - apply H; apply H0.
  Qed.

  End Facts.

  Instance t_equiv `{tA : t A leA eqA} : Equivalence eqA.
  Proof.
    constructor; [apply eq_refl | apply eq_sym | apply eq_trans ].
  Qed.

  Lemma morph_id `{tA : t A leA eqA} : morph leA eqA leA eqA (fun x : A => x).
  Proof. constructor.
    - apply PreO.morph_id.
    - solve_proper.
  Qed.

  Lemma morph_compose `{tA : t A leA eqA} `{tB : t B leB eqB} `{tC : t C leC eqC}
    : forall (f : A -> B) (g : B -> C), morph leA eqA leB eqB f
    -> morph leB eqB leC eqC g -> morph leA eqA leC eqC (fun x => g (f x)).
  Proof.
    intros f g H H0. destruct H, H0. constructor; intros.
    - apply (PreO.morph_compose (leB := leB)); eauto using PreO; apply PreO.
    - solve_proper.
  Qed.

  Instance le_properI `(tA : t A leA eqA)
    : Proper (eqA ==> eqA ==> iffT) leA.
  Proof. intros. apply le_proper. Qed.

  (** Morphisms must respect the equality relations on both their
      source (domain) and target (codomain). *)
  Instance morph_properI `(tA : t A leA eqA) `(tB : t B leB eqB) (f : A -> B)
    : morph leA eqA leB eqB f -> Proper (eqA ==> eqB) f.
  Proof.
    intros H. destruct H. unfold Proper, respectful. apply f_eq0.
  Qed.

  (** Now we will extend the preorders we had to partial orders
      in the obvious ways. There's really nothing interesting
      here. *)

  Definition eq_PreO {S : Type@{UA}} (le : crelation@{UA UP} S)
    (x y : S) : Type@{UP} :=
    (le x y * le y x)%type.

  Definition fromPreO {S : Type@{UA}} (le : crelation@{UA UP} S)
    {POS : PreO.t le}
    : PO.t le (eq_PreO le).
  Proof.
  constructor.
  - assumption.
  - unfold Proper, respectful, eq_PreO; intros x y H x' y' H0.
(** Broken in Coq
    destruct H, H0; split; intros; eauto using PreO.le_trans.
  - unfold eq_PreO. auto.
  Qed.
*)
  Admitted.

  End PO.

  Arguments t {A} _ _: clear implicits.
  Arguments morph {A} _ _ {B} _ _ _ : clear implicits.

  Definition one : t (fun (_ : True) _ => True) (fun _ _ => True).
  Proof.
    constructor; intros; auto.
    - apply PreO.one.
    - unfold Proper, respectful, iffT. auto.
  Qed.

  Definition two : t Bool.leb Logic.eq.
  Proof.
    constructor; intros.
    - apply PreO.two.
    - solve_proper.
    - destruct x, y; auto.
  Qed.

  Definition Nat : t le Logic.eq.
  Proof.
  constructor; intros.
  - apply PreO.Nat.
  - solve_proper.
  - apply Le.le_antisym; assumption.
  Qed.

  Definition discrete (A : Type) : t (@Logic.eq A) Logic.eq.
  Proof.
  constructor; intros.
  - apply PreO.discrete.
  - solve_proper.
  - assumption.
  Qed.

  Existing Instances t_equiv le_properI.

  Definition product `(tA : t A leA eqA) `(tB : t B leB eqB)
    : t (prod_op leA leB) (prod_op eqA eqB).
  Proof. constructor; intros.
   - apply PreO.product; apply PreO.
   - unfold prod_op, Proper, respectful. intros.
(** Proof broken...
     intuition;
     (eapply le_proper;
      [ ((eapply eq_sym; eassumption) || eassumption)
      | ((eapply eq_sym; eassumption) || eassumption)
      | eassumption ]).
   - unfold prod_op. destruct H, H0. split; apply le_antisym; intuition.
  Qed.
*)
  Admitted.

  Definition map {A B : Type} (f : A -> B)
    {leB eqB : crelation B} (tB : t leB eqB) : t
    (map_op f leB) (map_op f eqB).
  Proof. constructor; intros.
  - apply (PreO.map f PreO).
  - unfold map_op; split; simpl in *; intros.
    + rewrite <- X, <- X0. eassumption.
    + eapply le_proper; eassumption.
  - unfold map_op; eapply le_antisym; eauto.
  Qed.

  Definition pointwise {A} {B : A -> Type}
    {leB eqB : forall a, crelation (B a)}
    (tB : forall a, t (leB a) (eqB a)) : @t (forall a, B a) (pointwise_op leB)
     (pointwise_op eqB).
  Proof.
  constructor; intros.
  - apply (PreO.pointwise (fun _ => PreO)).
  - unfold pointwise_op. split; simpl in *; intros.
    rewrite <- X0. rewrite <- X. apply X1.
    rewrite X0. rewrite X. apply X1.
  - unfold pointwise_op. eauto using le_antisym.
  Qed.

  Definition morph_pointwise {A B C} `{tC : t C leC eqC} (f : B -> A)
    : morph (pointwise_op (fun _ => leC)) (pointwise_op (fun _ => eqC))
            (pointwise_op (fun _ => leC)) (pointwise_op (fun _ => eqC))
      (fun g b => g (f b)).
  Proof.
  constructor; intros; simpl in *; intros.
  - apply PreO.morph_pointwise.
  - unfold pointwise_op in *. unfold Proper, respectful.
    intros. firstorder.
  Qed.

  Local Instance prop : t (fun (P Q : Prop) => P -> Q) (fun P Q => P <-> Q).
  Proof.
  constructor; intuition. apply PreO.prop.
  split; simpl in *; intros; intuition.
  Qed.

  Axiom undefined : forall A, A.
  Set Printing Universes.
  Local Instance type : t arrow iffT.
  Proof.
  constructor; intuition.
  - do 3 apply PreO.type. apply undefined.
  - split; simpl in *; intros unfold iffT; firstorder.
  - split; assumption.
  Qed.

  Local Instance subset (A : Type) : @t (A -> Type) _ _ := pointwise (fun _ => type).

End PO.

(** Join semi-lattices, or directed sets. Here we take a partial order
    and add on a maximum operation. Natural numbers are
    one of many examples. We will often generalize sequences, which
    are functions of type (nat -> A), to nets, which are functions of
    type (I -> A), where I is a directed set. *)
Module JoinLat.

  Class Ops {A} : Type :=
  { le : crelation A
  ; eq : crelation A
  ; max : A -> A -> A
  }.

  Arguments Ops : clear implicits.

  (** When do the operations [le], [eq], and [max] actually represent
      a join semi-lattice? We need [le] and [eq] to be a partial order,
      and we need our [max] operation to actually implement a maximum. *)
  Class t {A : Type} {O : Ops A} : Type :=
  { PO :> PO.t le eq
  ; max_proper : Proper (eq ==> eq ==> eq) max
  ; max_ok : forall l r, PreO.max (le := le) l r (max l r)
  }.

  Arguments t : clear implicits.

  Instance max_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) max.
  Proof. intros. apply max_proper. Qed.

  Record morph `{OA : Ops A} `{OB : Ops B}
    {f : A -> B} : Type :=
   { f_PO : PO.morph le eq le eq f
   ; f_max : forall a b, eq (f (max a b)) (max (f a) (f b))
   }.

  Arguments morph {A} OA {B} OB f.

  (** A morphism on join semi-lattices respects the equality relation
      on its source and target. *)
  Lemma f_eq {A B OA OB} {tA : t A OA} {tB : t B OB} {f : A -> B} :
  morph OA OB f -> Proper (eq ==> eq) f.
  Proof.
    unfold Proper, respectful. intros H x y xy. apply (PO.f_eq (f_PO H)).
    assumption.
  Qed.

  Lemma morph_id {A OA} (tA : t A OA)
    : morph OA OA (fun x => x).
  Proof.
  constructor; intros.
  - apply PO.morph_id.
  - apply PO.eq_refl.
  Qed.

  Lemma morph_compose {A B C OA OB OC}
    (tA : t A OA) (tB : t B OB) (tC : t C OC)
    : forall f g, morph OA OB f
           -> morph OB OC g
           -> morph OA OC (fun x => g (f x)).
  Proof.
  intros. constructor; intros.
  - eapply PO.morph_compose; eapply f_PO; eassumption.
  - rewrite <- (f_max X0). rewrite (f_eq X0). reflexivity.
    apply (f_max X).
  Qed.

  (** Max is very boring for the one-point set *)
  Definition one_ops : Ops True :=
    {| le := fun _ _ => True
     ; eq := fun _ _ => True
     ; max := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof.
  constructor; intros; auto; unfold Proper, respectful; simpl; auto.
  - apply PO.one.
  - destruct l, r. constructor; tauto.
  Qed.

  (** Max for booleans is the boolean OR. *)
  Definition two_ops : Ops bool :=
    {| le := Bool.leb
     ; eq := Logic.eq
     ; max := orb
    |}.

  Definition two : t bool two_ops.
  Proof. constructor; intros; (
    apply PO.two || solve_proper
    ||
   (try constructor;
  repeat match goal with
  | [ b : bool |- _ ] => destruct b
  end; simpl; auto)).
  Qed.

  Local Instance Nat_ops : Ops nat :=
    {| le := Peano.le
     ; eq := Logic.eq
     ; max := Peano.max
    |}.

  Require Max.
  Local Instance Nat : t nat Nat_ops.
  Proof. constructor; intros.
  - apply PO.Nat.
  - solve_proper.
  - constructor. simpl. apply Max.le_max_l. apply Max.le_max_r.
    apply Max.max_lub.
  Qed.

  (** Max for propositions is the propositional OR, i.e., disjunction *)
  Local Instance prop_ops : Ops Prop :=
    {| le := fun P Q : Prop => P -> Q
     ; eq := fun P Q : Prop => P <-> Q
     ; max := fun P Q : Prop => P \/ Q
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof.
    constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Definition pointwise_ops {A B} (O : forall a : A, Ops (B a)) : Ops (forall a, B a) :=
    {| le := pointwise_op (fun a => @le _ (O a))
     ; eq := pointwise_op (fun a => @eq _ (O a))
     ; max :=  (fun f g a => @max _ (O a) (f a) (g a))
    |}.

  Definition pointwise
    `(tB : forall (a : A), t (B a) (OB a)) :
     t (forall a, B a) (pointwise_ops OB).
  Proof. constructor; simpl; intros.
    - apply PO.pointwise; intros. eapply @PO; apply tB.
    - unfold respectful, Proper, pointwise_op. intros.
      apply max_proper. apply X. apply X0.
    - constructor; unfold pointwise_op; simpl; intros; apply max_ok.
      apply X. apply X0.
  Qed.

  Definition morph_pointwise {C OC} {tC : t C OC} `(f : B -> A)
    : morph (pointwise_ops (fun _ => OC)) (pointwise_ops (fun _ => OC))
      (fun g b => g (f b)).
  Proof.
  constructor; intros; simpl in *; intros.
  - apply PO.morph_pointwise.
  - unfold pointwise_op. intros. apply PO.eq_refl.
  Qed.

  Local Instance subset (A : Type) : t (A -> Prop) (pointwise_ops (fun _ => prop_ops))
    := pointwise (fun _ => prop).

  Definition product_ops `(OA : Ops A) `(OB : Ops B) : Ops (A * B) :=
    {| le := prod_op le le
     ; eq := prod_op eq eq
     ; max := fun (x y : A * B) => (max (fst x) (fst y), max (snd x) (snd y))
    |}.

  Definition product {A OA B OB} (tA : t A OA) (tB : t B OB)
   : t (A * B) (product_ops OA OB).
  Proof. constructor;
    (apply PO.product; apply PO) ||
    (simpl; intros;
     constructor; unfold prod_op in *; simpl; intros;
    repeat match goal with
    | [ p : (_ * _)%type |- _ ] => destruct p; simpl in *
    | [ p : _ /\ _ |- _ ] => destruct p; simpl in *
    | [  |- (_ * _)%type ] => split
    | [ |- _ ] => eapply PreO.max_l; apply max_ok
    | [ |- _ ] => eapply PreO.max_r; apply max_ok
    | [ |- _ ] => apply max_proper; assumption
    end).
   eapply PreO.max_least. apply max_ok. assumption. assumption.
   eapply PreO.max_least. apply max_ok. assumption. assumption.
   Qed.

End JoinLat.

(** A meet semi-lattice is literally a join semi-lattice turned
    upside-down. Instead of having a [max] operation, it has a [min].
    The code is essentially copied from [JoinLat]. *)
Module MeetLat.

  Class Ops {A} : Type :=
  { le : crelation A
  ; eq : crelation A
  ; min : A -> A -> A
  }.

  Local Infix "<=" := le.
  Local Infix "===" := eq (at level 70).

  Arguments Ops : clear implicits.

  Class t {A : Type} {O : Ops A} : Type :=
  { PO :> PO.t le eq
  ; min_proper : Proper (eq ==> eq ==> eq) min
  ; min_ok : forall l r, PreO.min (le := le) l r (min l r)
  }.

  Arguments t : clear implicits.

  Instance min_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) min.
  Proof. intros. apply min_proper. Qed.

  Record morph `{OA : Ops A} `{OB : Ops B}
    {f : A -> B} : Type :=
   { f_PO : PO.morph le eq le eq f
   ; f_min : forall a b, f (min a b) === min (f a) (f b)
   }.

  Arguments morph {A} OA {B} OB f.

  Lemma f_eq {A B OA OB} {tA : t A OA} {tB : t B OB} {f : A -> B} :
  morph OA OB f -> Proper (eq ==> eq) f.
  Proof.
    unfold Proper, respectful. intros H x y xy. apply (PO.f_eq (f_PO H)).
    assumption.
  Qed.

  Lemma morph_id {A OA} (tA : t A OA)
    : morph OA OA (fun x => x).
  Proof.
  constructor; intros.
  - apply PO.morph_id.
  - apply PO.eq_refl.
  Qed.

  Lemma morph_compose {A B C OA OB OC}
    (tA : t A OA) (tB : t B OB) (tC : t C OC)
    : forall f g, morph OA OB f
           -> morph OB OC g
           -> morph OA OC (fun x => g (f x)).
  Proof.
  intros. constructor; intros.
  - eapply PO.morph_compose; eapply f_PO; eassumption.
  - rewrite <- (f_min X0). rewrite (f_eq X0). reflexivity.
    apply (f_min X).
  Qed.

  Section Props.
  Context `{tA : t A}.

  Lemma min_l : forall l r, min l r <= l.
  Proof.
  intros. eapply PreO.min_l. apply min_ok.
  Qed.

  Lemma min_r : forall l r, min l r <= r.
  Proof.
  intros. eapply PreO.min_r. apply min_ok.
  Qed.

  Lemma min_comm : forall l r, min l r === min r l.
  Proof.
  intros.
  apply PO.min_unique with l r.
  - apply min_ok.
  - apply PreO.min_comm. apply min_ok.
  Qed.

  Lemma min_assoc : forall a b c,
    min a (min b c) === min (min a b) c.
  Proof.
  intros.
  apply PO.min_unique with a (min b c).
  - apply min_ok.
  - eapply (Datatypes.snd (PreO.min_assoc _ a b c _ _ _ _ _)). apply min_ok.
  Unshelve. apply min_ok. apply min_ok.
  Qed.

  Lemma min_idempotent : forall a, min a a === a.
  Proof.
  intros. apply PO.min_unique with a a.
  apply min_ok. apply PreO.min_idempotent. apply PO.PreO.
  Qed.

  End Props.

  Definition one_ops : Ops True :=
    {| le := fun _ _ => True
     ; eq := fun _ _ => True
     ; min := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof.
  constructor; intros; auto; unfold Proper, respectful; simpl; auto.
  - apply PO.one.
  - destruct l, r. constructor; tauto.
  Qed.

  Definition two_ops : Ops bool :=
    {| le := Bool.leb
     ; eq := Logic.eq
     ; min := andb
    |}.

  Definition two : t bool two_ops.
  Proof. constructor; intros; (
    apply PO.two || solve_proper
    ||
   (try constructor;
  repeat match goal with
  | [ b : bool |- _ ] => destruct b
  end; simpl; auto)).
  Qed.

  Local Instance prop_ops : Ops Prop :=
    {| le := fun P Q : Prop => P -> Q
     ; eq := fun P Q : Prop => P <-> Q
     ; min := fun P Q : Prop => P /\ Q
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof.
    constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Definition pointwise_ops {A B} (O : forall a : A, Ops (B a)) : Ops (forall a, B a) :=
    {| le := pointwise_op (fun a => @le _ (O a))
     ; eq := pointwise_op (fun a => @eq _ (O a))
     ; min :=  (fun f g a => @min _ (O a) (f a) (g a))
    |}.

  Definition pointwise
    `(tB : forall (a : A), t (B a) (OB a)) :
     t (forall a, B a) (pointwise_ops OB).
  Proof. constructor; simpl; intros.
    - apply PO.pointwise; intros. eapply @PO; apply tB.
    - unfold respectful, Proper, pointwise_op. intros.
      apply min_proper; auto.
    - constructor; unfold pointwise_op; simpl; intros; apply min_ok; auto.
  Qed.

  Definition morph_pointwise {C OC} {tC : t C OC} `(f : B -> A)
    : morph (pointwise_ops (fun _ => OC)) (pointwise_ops (fun _ => OC))
      (fun g b => g (f b)).
  Proof.
  constructor; intros; simpl in *; intros.
  - apply PO.morph_pointwise.
  - unfold pointwise_op. intros. apply PO.eq_refl.
  Qed.

  Local Instance subset (A : Type) : t (A -> Prop) (pointwise_ops (fun _ => prop_ops))
    := pointwise (fun _ => prop).

  Definition product_ops `(OA : Ops A) `(OB : Ops B) : Ops (A * B) :=
    {| le := prod_op le le
     ; eq := prod_op eq eq
     ; min := fun (x y : A * B) => (min (fst x) (fst y), min (snd x) (snd y))
    |}.

  Definition product {A OA B OB} (tA : t A OA) (tB : t B OB)
   : t (A * B) (product_ops OA OB).
  Proof. constructor;
    (apply PO.product; apply PO) ||
    (simpl; intros;
     constructor; unfold prod_op in *; simpl; intros;
    repeat match goal with
    | [ p : (_ * _)%type |- _ ] => destruct p; simpl
    | [ p : _ /\ _ |- _ ] => destruct p; simpl
    | [  |- (_ * _)%type ] => split
    | [ |- _ ] => eapply PreO.min_l; apply min_ok
    | [ |- _ ] => eapply PreO.min_r; apply min_ok
    | [ |- _ ] => apply min_proper; assumption
    end).
   eapply PreO.min_greatest. apply min_ok. assumption. assumption.
   eapply PreO.min_greatest. apply min_ok. assumption. assumption.
   Qed.

  Lemma sc_monotone {A OA B OB} (tA : t A OA) (tB : t B OB) : forall (f : A -> B),
      PreO.scott_cont f ->
      forall x y : A, x <= y -> f x <= f y.
  Proof.
    intros f H x y xy.
    unfold PreO.scott_cont in H.
    pose (g := fun b : bool => if b then x else y).
    specialize (H _ g).
    assert (@PreO.directed _ MeetLat.le _ g).
    unfold PreO.directed.
    intros.
    exists y. destruct i, j; simpl; split;
         assumption || apply PreO.le_refl.
    specialize (H X y).
    assert (@PreO.sup _ MeetLat.le _ g y).
    constructor.
    intros. destruct i; simpl. assumption. reflexivity.
    intros m' X0. specialize (X0 false). simpl in X0.
    assumption.
    specialize (H X0).
    destruct H.
    specialize (sup_ge true). simpl in sup_ge.
    apply sup_ge.
  Qed.

End MeetLat.

(** A lattice is both a join semi-lattice and a meet semi-lattice;
    it has both a [max] operation and a [min] operation. Again,
    this is basically just copied from the two modules above. *)
Module Lattice.

  Class Ops {A : Type} : Type :=
    { le : crelation A
    ; eq : crelation A
    ; max : A -> A -> A
    ; min : A -> A -> A
    }.

  Arguments Ops : clear implicits.

  Class t {A : Type} {O : Ops A} : Type :=
  { PO :> PO.t le eq
  ; max_proper : Proper (eq ==> eq ==> eq) max
  ; max_ok : forall l r, PreO.max (le := le) l r (max l r)
  ; min_proper : Proper (eq ==> eq ==> eq) min
  ; min_ok : forall l r, PreO.min (le := le) l r (min l r)
  }.

  Arguments t : clear implicits.

   Definition toMeetLatOps' {A : Type} (ops : Ops A) : MeetLat.Ops A :=
    {| MeetLat.le := le
     ; MeetLat.eq := eq
     ; MeetLat.min := min
    |}.

  Instance toMeetLatOps {A : Type} : Ops A -> MeetLat.Ops A
    := toMeetLatOps'.

  Instance toMeetLat {A : Type} {ops} : t A ops -> MeetLat.t A (toMeetLatOps ops).
  Proof.
  intros. constructor.
  - apply PO.
  - apply min_proper.
  - apply min_ok.
  Qed.

  Definition toJoinLatOps' {A : Type} (ops : Ops A) : JoinLat.Ops A :=
    {| JoinLat.le := le
     ; JoinLat.eq := eq
     ; JoinLat.max := max
    |}.

  Instance toJoinLatOps {A : Type} : Ops A -> JoinLat.Ops A
    := toJoinLatOps'.

  Instance toJoinLat {A : Type} {ops} : t A ops -> JoinLat.t A (toJoinLatOps ops).
  Proof.
  intros. constructor.
  - apply PO.
  - apply max_proper.
  - apply max_ok.
  Qed.

  Instance max_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) max.
  Proof. intros. apply max_proper. Qed.

  Instance min_properI `(tA : t A)
    : Proper (eq ==> eq ==> eq) min.
  Proof. intros. apply min_proper. Qed.

  Record morph `{OA : Ops A} `{OB : Ops B}
    {f : A -> B} : Type :=
   { f_PO : PO.morph le eq le eq f
   ; f_max : forall a b, eq (f (max a b)) (max (f a) (f b))
   ; f_min : forall a b, eq (f (min a b)) (min (f a) (f b))
   }.

  Arguments morph {A} OA {B} OB f.

  Lemma f_eq {A B OA OB} {tA : t A OA} {tB : t B OB} {f : A -> B} :
  morph OA OB f -> Proper (eq ==> eq) f.
  Proof.
    unfold Proper, respectful. intros H x y xy. apply (PO.f_eq (f_PO H)).
    assumption.
  Qed.

  Lemma morph_id {A OA} (tA : t A OA)
    : morph OA OA (fun x => x).
  Proof.
  constructor; intros.
  - apply PO.morph_id.
  - apply PO.eq_refl.
  - apply PO.eq_refl.
  Qed.

  Lemma morph_compose {A B C OA OB OC}
    (tA : t A OA) (tB : t B OB) (tC : t C OC)
    : forall f g, morph OA OB f
           -> morph OB OC g
           -> morph OA OC (fun x => g (f x)).
  Proof.
  intros. constructor; intros.
  - eapply PO.morph_compose; eapply f_PO; eassumption.
  - rewrite <- (f_max X0). rewrite (f_eq X0). reflexivity.
    apply (f_max X).
  - rewrite <- (f_min X0). rewrite (f_eq X0). reflexivity.
    apply (f_min X).
  Qed.

  Definition one_ops : Ops True :=
    {| le := fun _ _ => True
     ; eq := fun _ _ => True
     ; max := fun _ _ => I
     ; min := fun _ _ => I
    |}.

  Definition one : t True one_ops.
  Proof.
  constructor; intros; auto; unfold Proper, respectful; simpl; auto.
  - apply PO.one.
  - destruct l, r. constructor; tauto.
  - destruct l, r. constructor; tauto.
  Qed.

  Definition two_ops : Ops bool :=
    {| le := Bool.leb
     ; eq := Logic.eq
     ; max := orb
     ; min := andb
    |}.

  Definition two : t bool two_ops.
  Proof. constructor; intros; (
    apply PO.two || solve_proper
    ||
   (try constructor;
  repeat match goal with
  | [ b : bool |- _ ] => destruct b
  end; simpl; auto)).
  Qed.

  Local Instance prop_ops : Ops Prop :=
    {| le := fun P Q : Prop => P -> Q
     ; eq := fun P Q : Prop => P <-> Q
     ; max := fun P Q : Prop => P \/ Q
     ; min := fun P Q : Prop => P /\ Q
    |}.

  Local Instance prop : t Prop prop_ops.
  Proof.
    constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Set Printing Universes.

  (*ST is the universe that T lies in. *)
  Local Instance type_ops@{ST T P} : Ops@{ST P P} Type@{T} :=
    {| le := arrow
     ; eq := iffT
     ; max := sum
     ; min := prod
    |}.

  Local Instance type : t Type type_ops.
  Proof.
  constructor; simpl; intros; constructor; simpl; firstorder.
  Qed.

  Definition pointwise_ops {A B} (O : forall a : A, Ops (B a)) : Ops (forall a, B a) :=
    {| le := pointwise_op (fun a => @le _ (O a))
     ; eq := pointwise_op (fun a => @eq _ (O a))
     ; max :=  (fun f g a => @max _ (O a) (f a) (g a))
     ; min :=  (fun f g a => @min _ (O a) (f a) (g a))
    |}.

  Definition pointwise
    `(tB : forall (a : A), t (B a) (OB a)) :
     t (forall a, B a) (pointwise_ops OB).
  Proof. constructor; simpl; intros.
    - apply PO.pointwise; intros. eapply @PO; apply tB.
    - unfold respectful, Proper, pointwise_op. intros.
      apply max_proper. apply X. apply X0.
    - constructor; unfold pointwise_op; simpl; intros; apply max_ok.
      apply X. apply X0.
    - unfold respectful, Proper, pointwise_op. intros.
      apply min_proper. apply X. apply X0.
    - constructor; unfold pointwise_op; simpl; intros; apply min_ok.
      apply X. apply X0.
  Qed.

  Definition morph_pointwise {C OC} {tC : t C OC} `(f : B -> A)
    : morph (pointwise_ops (fun _ => OC)) (pointwise_ops (fun _ => OC))
      (fun g b => g (f b)).
  Proof.
  constructor; intros; simpl in *; intros.
  - apply PO.morph_pointwise.
  - unfold pointwise_op. intros. apply PO.eq_refl.
  - unfold pointwise_op. intros. apply PO.eq_refl.
  Qed.

  Local Instance subset (A : Type) : t (A -> Prop) (pointwise_ops (fun _ => prop_ops))
    := pointwise (fun _ => prop).

  Definition product_ops `(OA : Ops A) `(OB : Ops B) : Ops (A * B) :=
    {| le := prod_op le le
     ; eq := prod_op eq eq
     ; max := fun (x y : A * B) => (max (fst x) (fst y), max (snd x) (snd y))
     ; min := fun (x y : A * B) => (min (fst x) (fst y), min (snd x) (snd y))
    |}.

  Definition product {A OA B OB} (tA : t A OA) (tB : t B OB)
   : t (A * B) (product_ops OA OB).
  Proof. constructor;
    (apply PO.product; apply PO) ||
    (simpl; intros;
     constructor; unfold prod_op in *; simpl; intros;
    repeat match goal with
    | [ p : (_ * _)%type |- _ ] => destruct p; simpl
    | [ p : _ /\ _ |- _ ] => destruct p; simpl
    | [  |- (_ * _)%type ] => split
    | [ |- _ ] => eapply PreO.max_l; apply max_ok
    | [ |- _ ] => eapply PreO.max_r; apply max_ok
    | [ |- _ ] => eapply PreO.min_l; apply min_ok
    | [ |- _ ] => eapply PreO.min_r; apply min_ok
    | [ |- _ ] => apply max_proper; assumption
    | [ |- _ ] => apply min_proper; assumption
    end).
   eapply PreO.max_least. apply max_ok. assumption. assumption.
   eapply PreO.max_least. apply max_ok. assumption. assumption.
   eapply PreO.min_greatest. apply min_ok. assumption. assumption.
   eapply PreO.min_greatest. apply min_ok. assumption. assumption.
   Qed.

End Lattice.