From Coq Require Import Ascii.
From Coq Require Import NArith.
From Coq Require Import ZArith.
From Coq Require Import Int63.
From Coq Require Import Lia.
From Coq Require String Ascii.

From EVM Require Import UInt63 Arith2.

Inductive nibble := Nibble (x3 x2 x1 x0: bool).
Inductive hex_digit :=
| x0 | x1 | x2 | x3
| x4 | x5 | x6 | x7
| x8 | x9 | xA | xB
| xC | xD | xE | xF.

Definition ascii_of_hex_digit (digit: hex_digit) (lower: bool)
: ascii
:= match digit with
   | x0 => "0"
   | x1 => "1"
   | x2 => "2"
   | x3 => "3"
   | x4 => "4"
   | x5 => "5"
   | x6 => "6"
   | x7 => "7"
   | x8 => "8"
   | x9 => "9"
   | xA => if lower then "a" else "A"
   | xB => if lower then "b" else "B"
   | xC => if lower then "c" else "C"
   | xD => if lower then "d" else "D"
   | xE => if lower then "e" else "E"
   | xF => if lower then "f" else "F"
   end.

Definition hex_digit_of_ascii (a: ascii)
: option hex_digit
:= match a with
   | "0" => Some x0
   | "1" => Some x1
   | "2" => Some x2
   | "3" => Some x3
   | "4" => Some x4
   | "5" => Some x5
   | "6" => Some x6
   | "7" => Some x7
   | "8" => Some x8
   | "9" => Some x9
   | "a" | "A" => Some xA
   | "b" | "B" => Some xB
   | "c" | "C" => Some xC
   | "d" | "D" => Some xD
   | "e" | "E" => Some xE
   | "f" | "F" => Some xF
   | _ => None
   end%char.

Definition is_hex_digit (a: ascii)
:= match hex_digit_of_ascii a with
   | Some _ => true
   | None => false
   end.

Lemma hex_digit_of_ascii_of_hex_digit (h: hex_digit) (lower: bool):
  hex_digit_of_ascii (ascii_of_hex_digit h lower) = Some h.
Proof.
destruct lower; destruct h; trivial.
Qed.

Lemma is_hex_digit_true (a: ascii):
  is_hex_digit a = true  ->  hex_digit_of_ascii a <> None.
Proof.
unfold is_hex_digit. now destruct hex_digit_of_ascii.
Qed.

Definition hex_digit_of_ascii' (a: ascii) (ok: is_hex_digit a = true)
: hex_digit
:= match hex_digit_of_ascii a as h return _ = h -> _ with
   | Some x => fun _ => x
   | None => fun E => False_rect _ (is_hex_digit_true a ok E)
   end eq_refl.

Lemma hex_digit_of_ascii_of_hex_digit' (h: hex_digit) (lower: bool)
                                       (ok: is_hex_digit (ascii_of_hex_digit h lower) = true):
  hex_digit_of_ascii' (ascii_of_hex_digit h lower) ok = h.
Proof.
destruct lower; destruct h; trivial.
Qed.

Definition nibble_of_hex_digit (digit: hex_digit)
: nibble
:= match digit with
   | x0 => Nibble false false false false
   | x1 => Nibble false false false true
   | x2 => Nibble false false true  false
   | x3 => Nibble false false true  true
   | x4 => Nibble false true  false false
   | x5 => Nibble false true  false true
   | x6 => Nibble false true  true  false
   | x7 => Nibble false true  true  true
   | x8 => Nibble true  false false false
   | x9 => Nibble true  false false true
   | xA => Nibble true  false true  false
   | xB => Nibble true  false true  true
   | xC => Nibble true  true  false false
   | xD => Nibble true  true  false true
   | xE => Nibble true  true  true  false
   | xF => Nibble true  true  true  true
   end.

Definition hex_digit_of_nibble (n: nibble)
: hex_digit
:= match n with
   | Nibble false false false false => x0
   | Nibble false false false true  => x1
   | Nibble false false true  false => x2
   | Nibble false false true  true  => x3
   | Nibble false true  false false => x4
   | Nibble false true  false true  => x5
   | Nibble false true  true  false => x6
   | Nibble false true  true  true  => x7
   | Nibble true  false false false => x8
   | Nibble true  false false true  => x9
   | Nibble true  false true  false => xA
   | Nibble true  false true  true  => xB
   | Nibble true  true  false false => xC
   | Nibble true  true  false true  => xD
   | Nibble true  true  true  false => xE
   | Nibble true  true  true  true  => xF
   end.

Lemma hex_digit_of_nibble_of_hex_digit (d: hex_digit):
  hex_digit_of_nibble (nibble_of_hex_digit d) = d.
Proof.
destruct d; easy.
Qed.

Lemma nibble_of_hex_digit_of_nibble (n: nibble):
  nibble_of_hex_digit (hex_digit_of_nibble n) = n.
Proof.
destruct n as (a3, a2, a1, a0).
destruct a3; destruct a2; destruct a1; destruct a0; easy.
Qed.

Definition N_of_hex_digit (digit: hex_digit)
: N
:= match digit with
   | x0 =>  0
   | x1 =>  1
   | x2 =>  2
   | x3 =>  3
   | x4 =>  4
   | x5 =>  5
   | x6 =>  6
   | x7 =>  7
   | x8 =>  8
   | x9 =>  9
   | xA => 10
   | xB => 11
   | xC => 12
   | xD => 13
   | xE => 14
   | xF => 15
   end.

Lemma N_of_hex_digit_ub (digit: hex_digit):
  (N_of_hex_digit digit < 16)%N.
Proof.
  destruct digit; cbn; rewrite<- N.ltb_lt; trivial.
Qed.

Definition N_of_nibble (n: nibble)
: N
:= let f (a: bool) := if a then xI else xO in
   match n with
   | Nibble true a2 a1 a0 => Npos (f a0 (f a1 (f a2 xH)))
   | Nibble false true a1 a0 => Npos (f a0 (f a1 xH))
   | Nibble false false true a0 => Npos (f a0 xH)
   | Nibble false false false true => Npos xH
   | Nibble false false false false => N0
   end.

Lemma N_of_nibble_bound (n: nibble):
  (N_of_nibble n < 16)%N.
Proof.
  destruct n as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0; easy.
Qed.

Lemma hex_digit_to_N_via_nibble (d: hex_digit):
  N_of_nibble (nibble_of_hex_digit d) = N_of_hex_digit d.
Proof.
  destruct d; easy.
Qed.

Lemma nibble_to_N_via_hex_digit (n: nibble):
  N_of_hex_digit (hex_digit_of_nibble n) = N_of_nibble n.
Proof.
  destruct n as (a3, a2, a1, a0); destruct a3; destruct a2; destruct a1; destruct a0; easy.
Qed.

Definition push_bit (n: N) (bit: bool)
: N
:= match n with
   | N0 => if bit then 1 else 0
   | Npos p => Npos ((if bit then xI else xO) p)
   end.

Lemma push_bit_arith (n: N) (bit: bool):
  push_bit n bit = (2 * n + if bit then 1 else 0)%N.
Proof.
destruct bit; now destruct n.
Qed.

Definition last_bit (n: N)
: bool
:= match n with
   | N0      | Npos (xO _) => false
   | Npos xH | Npos (xI _) => true
   end.

Lemma last_bit_odd (n: N):
  last_bit n = N.odd n.
Proof.
destruct n. { trivial. }
destruct p; easy.
Qed.

Lemma push_bit_then_shr1 (n: N) (bit: bool):
  N.div2 (push_bit n bit) = n.
Proof.
  destruct n; destruct bit; easy.
Qed.

Lemma last_of_push_bit (n: N) (bit: bool):
  last_bit (push_bit n bit) = bit.
Proof.
  destruct n; destruct bit; easy.
Qed.

Lemma push_last_bit (n: N):
  push_bit (N.div2 n) (last_bit n) = n.
Proof.
  destruct n. easy.
  destruct p; easy.
Qed.

Definition push_nibble (n: N) (nib: nibble)
: N
:= match nib with
   | Nibble a3 a2 a1 a0 => push_bit (push_bit (push_bit (push_bit n a3) a2) a1) a0
   end.

Lemma push_nibble_arith (n: N) (nib: nibble):
  push_nibble n nib = (16 * n + N_of_nibble nib)%N.
Proof.
destruct nib as (a3, a2, a1, a0).
unfold push_nibble.
repeat rewrite push_bit_arith.
repeat rewrite N.mul_add_distr_l.
repeat rewrite<- N.add_assoc.
f_equal.
{ now repeat rewrite N.mul_assoc. }
destruct a3; destruct a2; destruct a1; destruct a0; easy.
Qed.

Definition pop_nibble (n: N)
: N * nibble
:= let a0 := last_bit n in
   let n1 := N.div2 n in
   let a1 := last_bit n1 in
   let n2 := N.div2 n1 in
   let a2 := last_bit n2 in
   let n3 := N.div2 n2 in
   let a3 := last_bit n3 in
   let n4 := N.div2 n3 in
     (n4, Nibble a3 a2 a1 a0).

Lemma push_nibble_then_pop (n: N) (nib: nibble):
  pop_nibble (push_nibble n nib) = (n, nib).
Proof.
  destruct nib as (a3, a2, a1, a0). unfold pop_nibble. cbn.
  repeat rewrite push_bit_then_shr1.
  now repeat rewrite last_of_push_bit.
Qed.

Lemma pop_nibble_then_push (n: N):
  push_nibble (fst (pop_nibble n)) (snd (pop_nibble n)) = n.
Proof.
  destruct n. easy.
  unfold pop_nibble. unfold fst. unfold snd.
  unfold push_nibble.
  now repeat rewrite push_last_bit.
Qed.

Definition nibble_of_N (n: N)
: nibble
:= snd (pop_nibble n).

Lemma N_of_nibble_of_N (n: N) (B: (n < 16)%N):
  N_of_nibble (nibble_of_N n) = n.
Proof.
assert(P := pop_nibble_then_push n).
rewrite push_nibble_arith in P.
unfold nibble_of_N.
remember (N_of_nibble _) as k. clear Heqk.
remember (fst _) as z. clear Heqz.
lia.
Qed.

Definition pop_nibble_arith (a b: N) (B: (b < 16)%N):
  pop_nibble (16 * a + b) = (a, nibble_of_N b).
Proof.
enough (E: push_nibble a (nibble_of_N b) = (16 * a + b)%N).
{ rewrite<- E. apply push_nibble_then_pop. }
rewrite push_nibble_arith.
f_equal. apply N_of_nibble_of_N.
assumption.
Qed.

Definition pop_nibble_arith_small (b: N) (B: (b < 16)%N):
  pop_nibble b = (0%N, nibble_of_N b).
Proof.
rewrite<- (pop_nibble_arith _ _ B).
f_equal.
Qed.

Definition nibble_of_uint63 (i: int)
:= Nibble (0 < (i land 8))%int63
          (0 < (i land 4))%int63
          (0 < (i land 2))%int63
          (0 < (i land 1))%int63.

Definition uint63_of_nibble (n: nibble)
:= match n with
   | Nibble a8 a4 a2 a1 =>
       ((if a8 then 8%int63 else 0%int63)
         lor
        (if a4 then 4%int63 else 0%int63)
         lor
        (if a2 then 2%int63 else 0%int63)
         lor
        (if a1 then 1%int63 else 0%int63))%int63
   end.

Lemma nibble_of_uint63_of_nibble (n: nibble):
  nibble_of_uint63 (uint63_of_nibble n) = n.
Proof.
destruct n as (a3, a2, a1, a0).
destruct a3; destruct a2; destruct a1; destruct a0; easy.
Qed.

(** A direct conversion from a native int to a hex digit via an if cascade. *)
Definition hex_digit_of_uint63 (i: int)
:= if (0 < (i land 8))%int63 then
     if (0 < (i land 4))%int63 then
       if (0 < (i land 2))%int63 then
         if (0 < (i land 1))%int63 then xF else xE
       else
         if (0 < (i land 1))%int63 then xD else xC
     else
       if (0 < (i land 2))%int63 then
         if (0 < (i land 1))%int63 then xB else xA
       else
         if (0 < (i land 1))%int63 then x9 else x8
   else
     if (0 < (i land 4))%int63 then
       if (0 < (i land 2))%int63 then
         if (0 < (i land 1))%int63 then x7 else x6
       else
         if (0 < (i land 1))%int63 then x5 else x4
     else
       if (0 < (i land 2))%int63 then
         if (0 < (i land 1))%int63 then x3 else x2
       else
         if (0 < (i land 1))%int63 then x1 else x0.

Lemma hex_digit_of_nibble_of_uint63 (i: int):
  hex_digit_of_nibble (nibble_of_uint63 i) = hex_digit_of_uint63 i.
Proof.
unfold hex_digit_of_nibble. unfold nibble_of_uint63. unfold hex_digit_of_uint63.
destruct (0 < i land 8)%int63;
  destruct (0 < i land 4)%int63;
  destruct (0 < i land 2)%int63;
  destruct (0 < i land 1)%int63; easy.
Qed.

Lemma nibble_of_uint63_of_N (n: N):
  nibble_of_uint63 (uint63_of_N n) = nibble_of_N n.
Proof.
unfold nibble_of_N. unfold pop_nibble. cbn.
remember (uint63_of_N n) as i.
unfold nibble_of_uint63.
repeat rewrite last_bit_odd.
repeat rewrite N.div2_spec.
repeat rewrite N.shiftr_shiftr.
repeat rewrite<- N.testbit_odd.
rewrite<- N.bit0_odd.
repeat rewrite uint63_testbit_N_low_digit; try lia.
unfold get_digit. rewrite<- Heqi. cbn.
f_equal; trivial.
Qed.

(***************************************************************************************)

(* This is basically the standard Ascii thing except that bits are ordered MSB-to-LSB. *)
Inductive byte := Byte (a7 a6 a5 a4 a3 a2 a1 a0: bool).

Definition low_nibble (b: byte)
: nibble
:= match b with
   | Byte _ _ _ _ a3 a2 a1 a0 => Nibble a3 a2 a1 a0
   end.

Definition high_nibble (b: byte)
: nibble
:= match b with
   | Byte a7 a6 a5 a4 _ _ _ _ => Nibble a7 a6 a5 a4
   end.

Definition byte_of_nibbles (high low: nibble)
: byte
:= match high with
   | Nibble a7 a6 a5 a4 =>
      match low with
      | Nibble a3 a2 a1 a0 =>
         Byte a7 a6 a5 a4 a3 a2 a1 a0
      end
   end.

Lemma low_nibble_ok (high low: nibble):
  low_nibble (byte_of_nibbles high low) = low.
Proof.
  destruct low. destruct high. easy.
Qed.

Lemma high_nibble_ok (high low: nibble):
  high_nibble (byte_of_nibbles high low) = high.
Proof.
  destruct low. destruct high. easy.
Qed.

Lemma byte_of_nibbles_ok (b: byte):
  byte_of_nibbles (high_nibble b) (low_nibble b) = b.
Proof.
  now destruct b.
Qed.

Definition byte_of_hex_digits (high low: hex_digit)
: byte
:= byte_of_nibbles (nibble_of_hex_digit high) (nibble_of_hex_digit low).

Definition hex_digits_of_byte (b: byte)
: hex_digit * hex_digit
:= (hex_digit_of_nibble (high_nibble b),
    hex_digit_of_nibble (low_nibble b)).

Definition N_of_byte (b: byte)
: N
:= let f (a: bool) := if a then xI else xO in
   match b with
   | Byte true a6 a5 a4 a3 a2 a1 a0 => Npos (f a0 (f a1 (f a2 (f a3 (f a4 (f a5 (f a6 xH)))))))
   | Byte false true a5 a4 a3 a2 a1 a0 => Npos (f a0 (f a1 (f a2 (f a3 (f a4 (f a5 xH))))))
   | Byte false false true a4 a3 a2 a1 a0 => Npos (f a0 (f a1 (f a2 (f a3 (f a4 xH)))))
   | Byte false false false true a3 a2 a1 a0 => Npos (f a0 (f a1 (f a2 (f a3 xH))))
   | Byte false false false false true a2 a1 a0 => Npos (f a0 (f a1 (f a2 xH)))
   | Byte false false false false false true a1 a0 => Npos (f a0 (f a1 xH))
   | Byte false false false false false false true a0 => Npos (f a0 xH)
   | Byte false false false false false false false true => Npos xH
   | Byte false false false false false false false false => N0
   end.

Definition pop_byte (n: N)
: N * byte
:= let (n1, x) := pop_nibble n in
   let (n2, y) := pop_nibble n1 in
     (n2, byte_of_nibbles y x).

Definition byte_of_N (n: N)
: byte
:= snd (pop_byte n).

Lemma byte_of_N_arith (high low: N)
                       (H16: (high < 16)%N)
                       (L16: (low < 16)%N):
  byte_of_N (16 * high + low) = byte_of_nibbles (nibble_of_N high) (nibble_of_N low).
Proof.
unfold byte_of_N. unfold pop_byte.
rewrite (pop_nibble_arith _ _ L16).
remember (nibble_of_N low) as nib. clear Heqnib low L16.
rewrite (pop_nibble_arith_small _ H16).
trivial.
Qed.

Lemma byte_of_N_of_byte (b: byte):
  byte_of_N (N_of_byte b) = b.
Proof.
destruct b as (a7, a6, a5, a4, a3, a2, a1, a0).
destruct a7; destruct a6; destruct a5; destruct a4;
destruct a3; destruct a2; destruct a1; destruct a0; trivial.
Qed.

Definition byte_of_int (i: int)
:= Byte (0 < (i land 128))%int63
        (0 < (i land 64))%int63
        (0 < (i land 32))%int63
        (0 < (i land 16))%int63
        (0 < (i land 8))%int63
        (0 < (i land 4))%int63
        (0 < (i land 2))%int63
        (0 < (i land 1))%int63.

Definition int_of_byte (b: byte)
:= match b with
   | Byte b7 b6 b5 b4 b3 b2 b1 b0 =>
     (let a7 := if b7 then 128 else 0 in
      let a6 := if b6 then  64 lor a7 else a7 in
      let a5 := if b5 then  32 lor a6 else a6 in
      let a4 := if b4 then  16 lor a5 else a5 in
      let a3 := if b3 then   8 lor a4 else a4 in
      let a2 := if b2 then   4 lor a3 else a3 in
      let a1 := if b1 then   2 lor a2 else a2 in
                if b0 then   1 lor a1 else a1)%int63
   end.

Lemma byte_of_int_of_byte (b: byte):
  byte_of_int (int_of_byte b) = b.
Proof.
destruct b as (a7, a6, a5, a4, a3, a2, a1, a0).
destruct a7; destruct a6; destruct a5; destruct a4;
destruct a3; destruct a2; destruct a1; destruct a0; trivial.
Qed.

Fixpoint hex_of_bytes (b: list byte) (lower: bool)
: String.string
:= match b with
   | nil => String.EmptyString
   | (h :: t)%list =>
        let (hi, lo) := hex_digits_of_byte h in
          String.String (ascii_of_hex_digit hi lower)
                        (String.String (ascii_of_hex_digit lo lower)
                                       (hex_of_bytes t lower))
   end.

Definition byte_of_ascii (a: ascii)
:= let (b0, b1, b2, b3, b4, b5, b6, b7) := a in Byte b7 b6 b5 b4 b3 b2 b1 b0.

Fixpoint bytes_of_string (s: String.string)
: list byte
:= match s with
   | String.EmptyString => nil
   | String.String h t => byte_of_ascii h :: bytes_of_string t
   end.

(* TODO: to Str *)
Fixpoint string_forallb (f: ascii -> bool) (s: String.string)
: bool
:= match s with
   | String.EmptyString => true
   | String.String h t => f h && string_forallb f t
   end.

Lemma string_forallb_iff (f: ascii -> bool) (s: String.string):
  string_forallb f s = List.forallb f (String.list_ascii_of_string s).
Proof.
induction s; cbn. { trivial. }
f_equal. exact IHs.
Qed.

Definition is_hex_string (s: String.string)
: bool
:= Nat.even (String.length s)
    &&
   string_forallb is_hex_digit s.

Fixpoint bytes_of_hex (s: String.string)
                       (ok: is_hex_string s = true)
: list byte.
Proof.
refine(match s as s' return s = s' -> _ with
       | String.EmptyString => fun _ => nil
       | String.String h String.EmptyString => fun E => _
       | String.String hi (String.String lo rest) => fun E =>
           (byte_of_hex_digits (hex_digit_of_ascii' hi _) (hex_digit_of_ascii' lo _)
            ::
            bytes_of_hex rest _)%list
       end eq_refl);
  unfold is_hex_string in ok; unfold string_forallb in ok; subst; cbn in *;
  repeat (rewrite Bool.andb_true_iff in *); try easy.
fold string_forallb in ok. unfold is_hex_string.
rewrite Bool.andb_true_iff.
tauto.
Defined.

Lemma ascii_of_hex_digit_is_hex_digit (h: hex_digit) (lower: bool):
  is_hex_digit (ascii_of_hex_digit h lower) = true.
Proof.
unfold is_hex_digit. now rewrite hex_digit_of_ascii_of_hex_digit.
Qed.

Lemma hex_of_bytes_is_hex_string (b: list byte) (lower: bool)
: is_hex_string (hex_of_bytes b lower) = true.
Proof.
unfold is_hex_string. repeat (rewrite Bool.andb_true_iff).
split; induction b; try easy.
cbn. repeat rewrite ascii_of_hex_digit_is_hex_digit.
rewrite IHb. trivial.
Qed.

Lemma bytes_of_hex_of_bytes (b: list byte) (lower: bool):
  let hex := hex_of_bytes b lower in
  forall ok: is_hex_string hex = true,
    bytes_of_hex hex ok = b.
Proof.
induction b. { easy. }
cbn zeta in *. intro ok.
cbn. f_equal.
{
  unfold byte_of_hex_digits.
  repeat rewrite hex_digit_of_ascii_of_hex_digit'.
  repeat rewrite nibble_of_hex_digit_of_nibble.
  apply byte_of_nibbles_ok.
}
apply IHb.
Qed.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section AppendEntriesLeader.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition appendEntries_leader net :=
    forall p t leaderId prevLogIndex prevLogTerm entries leaderCommit h e,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      In e entries ->
      currentTerm (snd (nwState net h)) = t ->
      type (snd (nwState net h)) = Leader ->
      In e (log (snd (nwState net h))).

  Class append_entries_leader_interface : Prop :=
    {
      append_entries_leader_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          appendEntries_leader net
    }.
End AppendEntriesLeader.


Require Import FunctionalExtensionality.
Require Import Relations.
Require Import EquivDec.
Require Import Equality.
Require Import List.
Require Import Bool.
Require Import Lia.
Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import FMapPositive.
Require Import FSetPositive.
Require Import EquivDec.

From sflib Require Import sflib.
From Paco Require Import paco.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Time.
Require Import PromisingArch.lib.Lang.

Require Import PromisingArch.promising.Promising.

Set Implicit Arguments.

Section SIM.
  Variable sim_machine: forall (m_src m_tgt: Machine.t), Prop.

  Definition _sim (sim: Machine.t -> Machine.t -> Prop) (m1_src m1_tgt: Machine.t): Prop :=
    forall (WF1_SRC: Machine.wf m1_src)
      (WF1_TGT: Machine.wf m1_tgt)
      (MACHINE1: sim_machine m1_src m1_tgt),
      (<<TERMINAL:
        forall (TERMINAL_TGT: Machine.is_terminal m1_tgt),
        exists m2_src,
          (<<STEPS_SRC: rtc (Machine.step ExecUnit.step) m1_src m2_src>>) /\
          (<<TERMINAL_SRC: Machine.is_terminal m2_src>>) /\
          (<<MACHINE2: sim_machine m2_src m1_tgt>>)>>) /\
      (<<STEP:
        forall m2_tgt
          (STEP_TGT: Machine.step ExecUnit.step m1_tgt m2_tgt),
        exists m2_src,
          (<<STEPS_SRC: rtc (Machine.step ExecUnit.step) m1_src m2_src>>) /\
          (<<MACHINE2: sim_machine m2_src m2_tgt>>) /\
          (<<SIM: sim m2_src m2_tgt>>)>>)
  .
  #[local] Hint Unfold _sim: paco.

  Lemma sim_monotone: monotone2 _sim.
  Proof.
    ii. exploit IN; eauto. i. des.
    esplits; eauto. i.
    exploit STEP; eauto. i. des.
    esplits; eauto.
  Qed.
  #[local] Hint Resolve sim_monotone: paco.

  Definition sim := paco2 _sim bot2.
End SIM.

Section SIM_EU.
  Variable tid: Id.t.

  Definition SIM_EU: Type := ExecUnit.t (A:=unit) -> ExecUnit.t (A:=unit) -> Prop.

  Definition _sim_eu (sim_eu: SIM_EU) (eu1_src eu1_tgt: ExecUnit.t (A:=unit)): Prop :=
    (<<TERMINAL:
      forall (TERMINAL_TGT: ExecUnit.is_terminal eu1_tgt),
      exists eu2_src,
        (<<STEPS_SRC: rtc (ExecUnit.state_step tid) eu1_src eu2_src>>) /\
        (<<TERMINAL_SRC: ExecUnit.is_terminal eu2_src>>) /\
        (<<MEMORY2: ExecUnit.mem eu2_src = ExecUnit.mem eu1_tgt>>)>>) /\
    (<<STEP:
      forall eu2_tgt
        (STEP_TGT: ExecUnit.state_step tid eu1_tgt eu2_tgt),
      exists eu2_src,
        (<<STEP_SRC: rtc (ExecUnit.state_step tid) eu1_src eu2_src>>) /\
        (<<SIM: sim_eu eu2_src eu2_tgt>>)>>)
  .
  #[local] Hint Unfold _sim_eu: paco.

  Lemma sim_eu_monotone: monotone2 _sim_eu.
  Proof.
    ii. red in IN. des.
    red. esplits; eauto. i.
    exploit STEP; eauto. i. des.
    esplits; eauto.
  Qed.
  #[local] Hint Resolve sim_eu_monotone: paco.

  Definition sim_eu := paco2 _sim_eu bot2.
End SIM_EU.
Arguments sim_eu [_] _ _.


Require Import Thread0 SinglyLinkedList.

Module Make(M : S).
Import M.

Module T := Thread0.Make(M).
Import T.

Definition handlerS := SPEC reserving 49
  Al fs, PREmain[_] sched fs * mallocHeap 0.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * mallocHeap 0.

Definition m := bimport [[ "malloc"!"malloc" @ [mallocS], "malloc"!"free" @ [freeS],
                           "scheduler"!"init" @ [initS], "scheduler"!"exit" @ [exitS],
                           "scheduler"!"spawn" @ [spawnS], "scheduler"!"yield" @ [yieldS] ]]
  bmodule "test" {{
    bfunctionNoRet "handler"("i", "p", "r") [handlerS]
      "i" <- 0;; (* Loop counter *)
      "p" <- 0;; (* Pointer to head of list we will build *)

      [Al fs, PREmain[V] Ex ls, sll ls (V "p") * sched fs * mallocHeap 0]
      While ("i" < 10) {
        "r" <-- Call "malloc"!"malloc"(0, 2)
        [Al fs, PREmain[V, R] [| R <> 0 |] * [| freeable R 2 |] * R =?> 2 * Ex ls, sll ls (V "p") * sched fs * mallocHeap 0];;

        "r" *<- "i";;
        "r" + 4 *<- "p";;
        "p" <- "r";;
        "i" <- "i" + 1;;

        Yield
        [Al fs, PREmain[V] Ex ls, sll ls (V "p") * sched fs * mallocHeap 0]
      };;

      [Al fs, PREmain[V] Ex ls, sll ls (V "p") * sched fs * mallocHeap 0]
      While ("p" <> 0) {
        "r" <- "p";;
        "p" <-* "p" + 4;;
        Call "malloc"!"free"(0, "r", 2)
        [Al fs, PREmain[V] Ex ls, sll ls (V "p") * sched fs * mallocHeap 0];;

        Yield
        [Al fs, PREmain[V] Ex ls, sll ls (V "p") * sched fs * mallocHeap 0]
      };;

      Exit 50
    end with bfunctionNoRet "main"("x", "y") [mainS]
      Init
      [Al fs, PREmain[_] sched fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * mallocHeap 0];;

      Spawn("test"!"handler", 50)
      [Al fs, PREmain[_] sched fs * mallocHeap 0];;

      Exit 50
    end
  }}.

Theorem ok : moduleOk m.
  vcgen; abstract (sep SinglyLinkedList.hints; auto).
Qed.

End Make.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal33.

Set Printing Depth 1000.
Definition lfind_eval :=
@eq.

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .

Compute lfind_eval .


(* Copyright (c) 2015, Kestrel Institute
All rights reserved.

This program is free software; you can redistribute it and/or modify it under
the terms of the included LICENSE.txt file.

This program is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the LICENSE.txt for more details. *)

(*** Modeling specs and interpretations as Coq terms ***)

Require Import List.
Import ListNotations.
Require Export String.
Require Import Coq.Logic.Eqdep_dec.
Import EqNotations.
Require Import Coq.Arith.Lt.

(*** Misc Helper Functions ***)

(* The nth element of a list *without* a default *)
Fixpoint nth_nodef {A} n (l: list A) {struct l} : n < List.length l -> A :=
  match l return n < List.length l -> A with
    | nil => fun pf => match lt_n_0 _ pf with end
    | x::l' =>
      match n with
        | 0 => fun _ => x
        | S n' => fun pf => nth_nodef n' l' (lt_S_n _ _ pf)
      end
  end.

(*** Fields ***)

(* We define the type of fields in one place, so we can change it later *)
Definition Field : Set := string.
Definition Field_dec : forall (f1 f2 : Field), {f1=f2} + {f1<>f2} := string_dec.

Lemma Field_dec_eq f : { e : f = f | Field_dec f f = left e }.
  destruct (Field_dec f f).
  exists e; reflexivity.
  elimtype False; apply n; reflexivity.
Qed.

Lemma Field_dec_neq f f' : f <> f' -> { neq : f <> f' | Field_dec f f' = right neq }.
  destruct (Field_dec f f'); intros.
  elimtype False; apply (H e).
  exists n; reflexivity.
Qed.

(*** Specs ***)

(* Subtype predicates on ops, which include:
   + The trivial True predicate;
   + An equality to an existing object; and
   + An arbitrary functional predicate
 *)
Inductive OpPred (T:Type) : Type :=
| Pred_Trivial
| Pred_Eq (t':T)
| Pred_Fun (P:T -> Prop)
.

Arguments Pred_Trivial {T}.
Arguments Pred_Eq {T} t'.
Arguments Pred_Fun {T} P.

(* Whether an op satisfies an OpPred *)
Definition sats_op_pred {T} (p: OpPred T) : T -> Prop :=
  match p with
    | Pred_Trivial => fun _ => True
    | Pred_Eq t' => fun t => t = t'
    | Pred_Fun P => P
  end.

(* Allows writing "oppred t" instead of "sats_op_pred oppred t" *)
Coercion sats_op_pred : OpPred >-> Funclass.

(* The type of the representation of an axiom in a spec *)
Inductive SpecAxiom : Type :=
| specAxiom (f:Field) (P:Prop)
.

Arguments specAxiom f%string P%type.

(* Projections of SpecAxiom *)
Definition axiom_name (ax:SpecAxiom) :=
  let (f,_) := ax in f.
Definition axiom_prop (ax:SpecAxiom) :=
  let (_,P) := ax in P.

(* The inductive representation of specs, indexed by the op fields *)
Inductive Spec : Type :=
(* The base case contains the names and types of the axioms *)
| Spec_Axioms (axioms : list SpecAxiom) : Spec
(* The inductive case adds an op named f with zero or more definitions to the
rest of the spec, that can depend on any f equal to all the definitions *)
| Spec_Cons (f:Field) (T : Type) (oppred: OpPred T)
            (rest : forall t, oppred t -> Spec) : Spec
.

(* Make the field argument be parsed by Coq as a string *)
Arguments Spec_Cons f%string T oppred rest.

(* Unfold a definition *)
Definition def {T x} (t:T) (t__pf: t = x) : T := x.

(*** Models ***)

(* Helper for conjoining all the axioms in an axiom list *)
Fixpoint conjoin_axioms (axioms : list SpecAxiom) : Prop :=
  match axioms with
    | [] => True
    | [specAxiom _ P] => P
    | (specAxiom _ P) :: axioms' => P /\ conjoin_axioms axioms'
  end.

(* Helper for proving conjoin_axioms applied to a cons *)
Lemma conjoin_axioms_cons f (P:Prop) axioms :
  P -> conjoin_axioms axioms -> conjoin_axioms (specAxiom f P :: axioms).
  intros; destruct axioms; try split; assumption.
Qed.

(* Helper for destructing conjoin_axioms applied to a cons *)
Lemma conjoin_axioms_destruct f (P:Prop) axioms :
  conjoin_axioms (specAxiom f P :: axioms) -> P /\ conjoin_axioms axioms.
  intro H; destruct axioms; try (destruct H); split; try assumption; try constructor.
Qed.

(* The type of an op of type T, a proof of its oppred, and some further type U
that depends on the op; this is essentially a doubly nested dependent pair. *)
Inductive OpCons (T:Type) (oppred:OpPred T)
          (U: forall t, oppred t -> Type) : Type :=
| opCons (t:T) (pf:oppred t) (model':U t pf)
.

Arguments opCons {T oppred U} t pf model'.

(* Build the type of the op of a spec *)
Fixpoint spec_ops spec : Type :=
  match spec with
    | Spec_Axioms axioms => unit
    | Spec_Cons f T oppred rest =>
      OpCons T oppred (fun t pf => spec_ops (rest t pf))
  end.

(* Build the type of the models of spec as a nested dependent pair *)
Fixpoint spec_model spec : spec_ops spec -> Prop :=
  match spec return spec_ops spec -> Prop with
    | Spec_Axioms axioms =>
      fun _ => conjoin_axioms axioms
    | Spec_Cons f T oppred rest =>
      fun ops =>
        let (t,pf,ops') := ops in
        spec_model (rest t pf) ops'
  end.

(* Project the first op of a spec *)
Definition ops_head {f T oppred rest}
           (ops: spec_ops (Spec_Cons f T oppred rest)) : T :=
  let (t,pf,ops') := ops in t.

(* Project the proof that the first op of a spec meets its oppred *)
Definition ops_proof {f T oppred rest}
           (ops: spec_ops (Spec_Cons f T oppred rest)) :
  oppred (ops_head ops) :=
  match ops with
    | opCons t pf ops' => pf
  end.

(* Project the tail of the ops of a spec *)
Definition ops_rest {f T oppred rest}
           (ops: spec_ops (Spec_Cons f T oppred rest)) :
  spec_ops (rest (ops_head ops) (ops_proof ops)) :=
  match ops with
    | opCons t pf ops' => ops'
  end.

(*** Spec Examples ***)

(* Helper notation for building specs (FIXME) *)
(*
Notation "'DeclOp' f T rest" := (Spec_DeclOp f%string $(solve_not_in_list)$ T rest)
  (at level 0, f at level 0, T at level 0, rest at level 0).
Notation "'DefOp' f T t rest" := (Spec_DefOp f $(solve_not_in_list)$ T rest) (at level 0).
*)
(*
Notation "'Axioms f1 t1 ; .. ; fn tn'" :=
  (Spec_Axioms (cons (f1, t1) .. (cons (fn, tn) nil)))
  (at level 0).
*)

(* Example 1:  op n:nat;  axiom gt1: n > 1 *)
Definition spec_example_1 :=
  Spec_Cons "n" nat Pred_Trivial
              (fun n _ => Spec_Axioms [specAxiom "gt1" (n > 1)]).

(* Example 2:  op n:nat := 2;  (no axioms) *)
Definition spec_example_2 :=
  Spec_Cons "n" nat (Pred_Eq 2)
              (fun n _ => Spec_Axioms []).

(* Example 3:  op T:Set := nat;  op n:T__def;  axiom gt1: n > 1 *)
Definition spec_example_3 :=
  Spec_Cons
    "T" Set (Pred_Eq nat)
    (fun T T__pf =>
       Spec_Cons "n" (def T T__pf) Pred_Trivial
                   (fun n _ => Spec_Axioms [specAxiom "gt1" (n > 1)])).

(* Example 4: Monoids *)
Definition spec_example_monoid :=
  Spec_Cons
    "T" Set Pred_Trivial
    (fun T _ =>
       Spec_Cons
         "m_zero" T Pred_Trivial
         (fun m_zero _ =>
            Spec_Cons
              "m_plus" (T -> T -> T) Pred_Trivial
              (fun m_plus _ =>
                 Spec_Axioms
                   [specAxiom "m_zero_left" (forall x, m_plus m_zero x = x);
                     specAxiom "m_zero_right" (forall x, m_plus x m_zero = x);
                     specAxiom "m_plus_assoc"
                             (forall x y z,
                                m_plus x (m_plus y z) = m_plus (m_plus x y) z)]))).

(* Example 5: Groups *)
Definition spec_example_group :=
  Spec_Cons
    "T" Set Pred_Trivial
    (fun T _ =>
       Spec_Cons
         "g_zero" T Pred_Trivial
         (fun g_zero _ =>
            Spec_Cons
              "g_plus" (T -> T -> T) Pred_Trivial
              (fun g_plus _ =>
                 Spec_Cons
                   "g_inv" (T -> T) Pred_Trivial
                   (fun g_inv _ =>
                        Spec_Axioms
                          [specAxiom "g_zero_left" (forall x, g_plus g_zero x = x);
                            specAxiom "g_zero_right" (forall x, g_plus x g_zero = x);
                            specAxiom "g_plus_assoc"
                                    (forall x y z,
                                       g_plus x (g_plus y z) = g_plus (g_plus x y) z);
                            specAxiom "g_inv_left"
                                    (forall (x:T), g_plus (g_inv x) x = g_zero);
                            specAxiom "g_inv_right"
                                    (forall (x:T), g_plus x (g_inv x) = g_zero)
    ])))).

(* Example 6: The Natural Numbers as a Monoid *)
Definition spec_example_natmonoid :=
Spec_Cons "T" Type (@Pred_Eq Type nat)
  (fun T__param T__proof =>
   Spec_Cons "m_zero" (def T__param T__proof) (Pred_Eq 0)
     (fun m_zero__param m_zero__proof =>
      Spec_Cons "m_plus"
        (def T__param T__proof ->
         def T__param T__proof -> def T__param T__proof)
        (Pred_Eq Nat.add)
        (fun m_plus__param m_plus__proof
         =>
         Spec_Axioms
           (specAxiom "m_zero_left"
              (forall x : def T__param T__proof,
               def m_plus__param m_plus__proof
                 (def m_zero__param m_zero__proof) x = x)
            :: (specAxiom "m_zero_right"
                  (forall x : def T__param T__proof,
                   def m_plus__param m_plus__proof x
                     (def m_zero__param m_zero__proof) = x)
                :: specAxiom "m_plus_assoc"
                     (forall x y z : def T__param T__proof,
                      def m_plus__param m_plus__proof x
                        (def m_plus__param m_plus__proof y z) =
                      def m_plus__param m_plus__proof
                        (def m_plus__param m_plus__proof x y) z) :: nil)%list)))).

Definition spec_example_ops_natmonoid
           T__param T__proof m_zero__param m_zero__proof m_plus__param m_plus__proof :
  spec_ops spec_example_natmonoid :=
  opCons
    T__param T__proof
    (opCons
       m_zero__param m_zero__proof
       (opCons m_plus__param m_plus__proof tt)).

Definition spec_example_model_natmonoid
           T__param T__proof m_zero__param m_zero__proof m_plus__param m_plus__proof
           (m_zero_left__param :
              forall x : def T__param T__proof,
               def m_plus__param m_plus__proof
                 (def m_zero__param m_zero__proof) x = x)
           (m_zero_right__param :
              forall x : def T__param T__proof,
               def m_plus__param m_plus__proof
                 x (def m_zero__param m_zero__proof) = x)
           (m_plus_assoc__param :
              forall x y z : def T__param T__proof,
                def m_plus__param m_plus__proof x
                    (def m_plus__param m_plus__proof y z) =
                def m_plus__param m_plus__proof
                    (def m_plus__param m_plus__proof x y) z) :
  spec_model spec_example_natmonoid
             (spec_example_ops_natmonoid T__param T__proof m_zero__param
                                         m_zero__proof m_plus__param m_plus__proof) :=
  conj m_zero_left__param (conj m_zero_right__param m_plus_assoc__param).

(*** Interpretations ***)

(* An interpretation from spec1 into spec2 is a pair of functions that map the
ops and the models, respectively, of spec2 to those of spec1 *)
Definition Interpretation spec1 spec2 :=
  { ops_f: spec_ops spec2 -> spec_ops spec1 |
    forall ops, spec_model spec2 ops -> spec_model spec1 (ops_f ops) }.

(* Helper to build an interpretation from spec1 to spec2 *)
Definition mkInterp {spec1 spec2} ops_f model_f : Interpretation spec1 spec2 :=
  exist _ ops_f model_f.

(* Apply the ops map of an interpretation *)
Definition map_ops {spec1 spec2} (i:Interpretation spec1 spec2) :
  spec_ops spec2 -> spec_ops spec1 :=
  match i with exist _ ops_f model_f => ops_f end.

(* Apply the model map of an interpretation *)
Definition map_model {spec1 spec2} (i:Interpretation spec1 spec2) :
  forall ops2, spec_model spec2 ops2 -> spec_model spec1 (map_ops i ops2) :=
  match i with exist _ ops_f model_f => model_f end.

(* The identity interpretation *)
Definition interp_id (spec:Spec) : Interpretation spec spec :=
  mkInterp id (fun _ model => model).

(* Composing interpretations *)
Definition interp_compose {s1 s2 s3}
           (i2: Interpretation s2 s3) (i1: Interpretation s1 s2) :
  Interpretation s1 s3 :=
  mkInterp (fun ops3 => map_ops i1 (map_ops i2 ops3))
           (fun ops3 model3 => map_model i1 _ (map_model i2 _ model3)).

(* Build an interpretation between the tails of two specs that have the same
head into an interpretation between the whole of the two specs *)
Definition interp_cons f T (oppred: OpPred T)
           {spec1 spec2 : forall t, oppred t -> Spec}
           (i: forall t pfs, Interpretation (spec1 t pfs) (spec2 t pfs)) :
  Interpretation (Spec_Cons f T oppred spec1)
                 (Spec_Cons f T oppred spec2) :=
  mkInterp (fun ops2:spec_ops (Spec_Cons f T oppred spec2) =>
              let (t,pf,ops2') := ops2 in
              opCons t pf (map_ops (i _ _) ops2') : spec_ops (Spec_Cons _ _ _ _))
           (fun ops2 =>
              match ops2
                    return spec_model (Spec_Cons f T oppred spec2) ops2 ->
                           spec_model
                             (Spec_Cons f T oppred spec1)
                             (let (t,pf,ops2') := ops2 in
                              opCons t pf (map_ops (i _ _) ops2')) with
                | opCons t pf ops2' =>
                  fun model2 =>
                    map_model (i t pf) ops2' model2
              end).

(* The simpler version, that does not destruct ops2. We choose the above version
to make it more efficient to compute with this interpretation. *)
(*
Definition interp_cons f T (oppred: OpPred T)
           {spec1 spec2 : forall t, oppred t -> Spec}
           (i: forall t pfs, Interpretation (spec1 t pfs) (spec2 t pfs)) :
  Interpretation (Spec_Cons f T oppred spec1)
                 (Spec_Cons f T oppred spec2) :=
  mkInterp (fun ops2 =>
              ops_cons (ops_head ops2) (ops_proof ops2)
                       (map_ops (i _ _) (ops_rest ops2)))
           (fun ops2 model2 =>
              map_model (i _ _) _ model2).
*)

(* Take an interpretation from spec1 to spec2 and cons an op onto spec2 *)
Definition interp_cons_r f T (oppred: OpPred T)
           {spec1} {spec2: forall t, oppred t -> Spec}
           (i: forall t pfs, Interpretation spec1 (spec2 t pfs)) :
  Interpretation spec1 (Spec_Cons f T oppred spec2) :=
  mkInterp (fun ops2:spec_ops (Spec_Cons f T oppred spec2) =>
              let (t,pf,ops2') := ops2 in
              map_ops (i t pf) ops2')
           (fun ops2 =>
              match ops2
                    return spec_model (Spec_Cons f T oppred spec2) ops2 ->
                           spec_model spec1
                                      (let (t,pf,ops2') := ops2 in
                                       map_ops (i _ _) ops2') with
                | opCons t pf ops2' =>
                  fun model2 =>
                    map_model (i t pf) ops2' model2
              end).

(* The simpler version, that does not destruct ops2. We choose the above version
to make it more efficient to compute with this interpretation. *)
(*
Definition interp_cons_r f T (oppred: OpPred T)
           {spec1} {spec2: forall t, oppred t -> Spec}
           (i: forall t pfs, Interpretation spec1 (spec2 t pfs)) :
  Interpretation spec1 (Spec_Cons f T oppred spec2) :=
  mkInterp (fun ops2 => map_ops (i (ops_head ops2) (ops_proof ops2)) (ops_rest ops2))
           (fun ops2 model2 => map_model (i (ops_head ops2) (ops_proof ops2)) _ model2).
*)

(*** Example Interpretations ***)

(* Interpret T as nat and n as n for spec_example_3 into spec_example_2 *)
Program Definition interp_example_3_2 : Interpretation spec_example_3 spec_example_2 :=
  fun ops2 =>
    match ops2 with
      | opCons n n__proof tt =>
        (opCons
           (oppred:= Pred_Eq nat) nat eq_refl
           (opCons (oppred:=Pred_Trivial) n I
                   (tt : spec_ops (Spec_Axioms _)))) : spec_ops spec_example_3
    end.
Obligation 1.
destruct ops as [ n n__proof ops ]; destruct ops.
rewrite n__proof.
auto.
Qed.

(*** Appending Specs ***)

(* Append axioms to the end of a spec *)
Fixpoint spec_append_axioms spec axioms2 : Spec :=
  match spec with
    | Spec_Axioms axioms1 => Spec_Axioms (axioms1 ++ axioms2)
    | Spec_Cons f T oppred rest =>
      Spec_Cons f T oppred (fun t pf => spec_append_axioms (rest t pf) axioms2)
  end.

Lemma conjoin_axioms_append1 axioms1 axioms2 :
  conjoin_axioms (axioms1 ++ axioms2) -> conjoin_axioms axioms1.
  induction axioms1.
  intros; constructor.
  intros; destruct a; destruct (conjoin_axioms_destruct _ _ _ H).
  apply conjoin_axioms_cons; [ assumption | apply IHaxioms1; assumption ].
Qed.

Lemma conjoin_axioms_append2 axioms1 axioms2 :
  conjoin_axioms (axioms1 ++ axioms2) -> conjoin_axioms axioms2.
  induction axioms1; intros.
  assumption.
  apply IHaxioms1.
  destruct a; destruct (conjoin_axioms_destruct _ _ _ H); assumption.
Qed.

(* The interpretation from any spec to the result of appending axioms to it *)
Fixpoint append_axioms_interp1 spec axioms2 :
  Interpretation spec (spec_append_axioms spec axioms2) :=
  match spec return Interpretation spec (spec_append_axioms spec axioms2) with
    | Spec_Axioms axioms1 =>
      mkInterp
        (spec1:=Spec_Axioms axioms1) (spec2:=Spec_Axioms (axioms1++axioms2))
        id (fun _ model => conjoin_axioms_append1 axioms1 axioms2 model)
    | Spec_Cons f T oppred rest =>
      interp_cons f T oppred (fun t pf => append_axioms_interp1 (rest t pf) axioms2)
  end.

(* The interpretation from axioms to the result of appending them to a spec *)
Fixpoint append_axioms_interp2 spec axioms2 :
  Interpretation (Spec_Axioms axioms2) (spec_append_axioms spec axioms2) :=
  match spec return Interpretation (Spec_Axioms axioms2) (spec_append_axioms spec axioms2) with
    | Spec_Axioms axioms1 =>
      mkInterp
        (spec1:=Spec_Axioms axioms2) (spec2:=Spec_Axioms (axioms1++axioms2))
        (fun _ => tt)
        (fun _ model => conjoin_axioms_append2 axioms1 axioms2 model)
    | Spec_Cons f T oppred rest =>
      interp_cons_r f T oppred
                    (fun t pf => append_axioms_interp2 (rest t pf) axioms2)
  end.

(* Append one spec after another, where the spec being appended can depend on
the ops of the spec it is coming after *)
Fixpoint spec_append spec1 : (spec_ops spec1 -> Spec) -> Spec :=
  match spec1 return (spec_ops spec1 -> Spec) -> Spec with
    | Spec_Axioms axioms1 =>
      fun spec2 => spec_append_axioms (spec2 tt) axioms1
    | Spec_Cons f T oppred rest =>
      fun spec2 =>
        Spec_Cons f T oppred
                    (fun t pf =>
                       spec_append (rest t pf)
                                   (fun ops1 => spec2 (opCons t pf ops1)))
  end.

(* Helper for the next definition *)
Definition append_axioms_interp spec spec1 axioms2
           (ops_f : spec_ops spec1 -> spec_ops spec)
           (model_f :
              forall ops1,
                conjoin_axioms axioms2 -> spec_model spec1 ops1 ->
                spec_model spec (ops_f ops1)) :
  Interpretation spec (spec_append_axioms spec1 axioms2) :=
  mkInterp (fun ops1 =>
              ops_f (map_ops (append_axioms_interp1 spec1 axioms2) ops1))
           (fun ops1 model1 =>
              model_f (map_ops (append_axioms_interp1 spec1 axioms2) ops1)
                      (map_model (append_axioms_interp2 spec1 axioms2) ops1 model1)
                      (map_model (append_axioms_interp1 spec1 axioms2) ops1 model1)).

(* The interpretation from a spec to the result of appending another spec to it *)
Fixpoint interp_append1 spec1 :
  forall spec2, Interpretation spec1 (spec_append spec1 spec2) :=
  match spec1 return
        forall spec2, Interpretation spec1 (spec_append spec1 spec2) with
    | Spec_Axioms axioms1 =>
      fun spec2 => append_axioms_interp2 (spec2 tt) axioms1
    | Spec_Cons f T oppred rest =>
      fun spec2 =>
        interp_cons f T oppred
                    (fun t pf =>
                       interp_append1 (rest t pf)
                                      (fun ops1 => spec2 (opCons t pf ops1)))
  end.

(* Extract the ops for spec2 from ops for (spec_append spec1 spec2). This
function, along with interp_append2_model, below, is essentially a dependent
interpretation, i.e., an Interpretation spec2 (spec_append spec1 spec2) where
spec2 depends on the ops being passed in for (spec_append spec1 spec2). *)
Fixpoint interp_append2_ops spec1 :
  forall spec2 (ops12: spec_ops (spec_append spec1 spec2)),
    spec_ops (spec2 (map_ops (interp_append1 spec1 spec2) ops12)) :=
  match spec1 with
    | Spec_Axioms axioms1 =>
      fun spec2 ops12 =>
        match (map_ops (interp_append1 (Spec_Axioms axioms1) spec2) ops12) as ops1
              return spec_ops (spec2 ops1) with
          | tt => map_ops (append_axioms_interp1 _ _) ops12
        end
    | Spec_Cons f T oppred rest =>
      fun spec2 ops12 =>
        match ops12 return
              spec_ops (spec2 (map_ops (interp_append1 _ spec2) ops12)) with
          | opCons t pf ops12' =>
            interp_append2_ops (rest t pf) (fun ops1 => spec2 (opCons t pf ops1))
                               ops12'
        end
  end.

(* Extract a model of spec2 from a model of (spec_append spec1 spec2). This is
like a dependent interpretation; see the comments for interp2_append2_ops. *)
Lemma interp_append2_model spec1 spec2
      (ops12: spec_ops (spec_append spec1 spec2))
      (model12: spec_model (spec_append spec1 spec2) ops12) :
  spec_model (spec2 (map_ops (interp_append1 spec1 spec2) ops12))
             (interp_append2_ops spec1 spec2 ops12).
  revert spec2 ops12 model12; induction spec1; intros.
  unfold interp_append2_ops.
  destruct (map_ops (interp_append1 (Spec_Axioms axioms) spec2) ops12).
  apply map_model; apply model12.
  destruct ops12 as [ t pf ops12' ].
  apply (H t pf (fun ops1 : spec_ops (rest t pf) => spec2 (opCons t pf ops1))).
  assumption.
Qed.

(* Build an interpretation into the append of two specs from a funky binary sort
of interpretation into the two specs that are being appended. *)
Definition interp_append spec spec1 spec2
           (ops_f: forall ops1, spec_ops (spec2 ops1) -> spec_ops spec)
           (model_f:
              forall ops1 ops2,
                spec_model spec1 ops1 -> spec_model (spec2 ops1) ops2 ->
                spec_model spec (ops_f ops1 ops2)) :
  Interpretation spec (spec_append spec1 spec2) :=
  mkInterp
    (fun ops12 =>
       ops_f (map_ops (interp_append1 spec1 spec2) ops12)
             (interp_append2_ops spec1 spec2 ops12))
    (fun ops12 model12 =>
       model_f (map_ops (interp_append1 spec1 spec2) ops12)
               (interp_append2_ops spec1 spec2 ops12)
               (map_model (interp_append1 spec1 spec2) ops12 model12)
               (interp_append2_model spec1 spec2 ops12 model12)).

(*** Spec Overlap ***)

(* NotInSpec f spec is a proof that f is not used as an op name in spec *)
Inductive NotInSpec (f:Field) : Spec -> Prop :=
| NotInSpec_base axioms : NotInSpec f (Spec_Axioms axioms)
| NotInSpec_cons f' T oppred rest :
    f <> f' ->
    (forall t pf, NotInSpec f (rest t pf)) ->
    NotInSpec f (Spec_Cons f' T oppred rest)
.

(* Tactic to prove NotInSpec goals *)
Ltac prove_not_in_spec :=
  match goal with
    | |- NotInSpec ?f (Spec_Cons ?f' _ _ _) =>
      apply NotInSpec_cons; [ discriminate | intros; prove_not_in_spec ]
    | |- NotInSpec ?f (Spec_Axioms _) =>
      apply NotInSpec_base
  end.

(* Helper lemma to prove not in goals *)
Lemma not_in_cons {A} (x y:A) l :
  y <> x -> ~(In x l) -> ~(In x (y::l)).
  intros neq not_in in_xy.
  destruct in_xy; contradiction.
Qed.

(* Tactic to prove ~(In f l) goals *)
Ltac prove_not_in_list :=
  match goal with
    | |- ~(In ?f (cons ?f' ?l)) =>
      apply not_in_cons; [ discriminate | prove_not_in_list ]
    | |- ~(In ?f nil) =>
      apply in_nil
  end.

(* Helper type for SpecOverlap *)
Inductive AxiomOverlap : list SpecAxiom -> list SpecAxiom -> Type :=
| AxiomOverlap_base : AxiomOverlap [] []
| AxiomOverlap_eq ax_name ax_tp axioms1 axioms2 :
    AxiomOverlap axioms1 axioms2 ->
    AxiomOverlap (specAxiom ax_name ax_tp::axioms1)
                 (specAxiom ax_name ax_tp::axioms2)
| AxiomOverlap_neq1 ax_name ax_tp axioms1 axioms2 :
    ~(In ax_name (map axiom_name axioms2)) ->
    AxiomOverlap axioms1 axioms2 ->
    AxiomOverlap (specAxiom ax_name ax_tp::axioms1) axioms2
| AxiomOverlap_neq2 ax_name ax_tp axioms1 axioms2 :
    ~(In ax_name (map axiom_name axioms1)) ->
    AxiomOverlap axioms1 axioms2 ->
    AxiomOverlap axioms1 (specAxiom ax_name ax_tp::axioms2)
.

(* SpecOverlap spec1 spec2 is a correlation between spec1 and spec2 that
identifies some sequence of ops and axioms that occur in both spec1 and spec2 in
the same order and with the same types and subtype predictes. In fact, an
element of SpecOverlap spec1 spec2 is the maximal such sequence. *)
Inductive SpecOverlap : Spec -> Spec -> Type :=
| SpecOverlap_base axioms1 axioms2 :
    AxiomOverlap axioms1 axioms2 ->
    SpecOverlap (Spec_Axioms axioms1) (Spec_Axioms axioms2)
| SpecOverlap_eq f T oppred rest1 rest2 :
    (forall t pf, SpecOverlap (rest1 t pf) (rest2 t pf)) ->
    SpecOverlap (Spec_Cons f T oppred rest1) (Spec_Cons f T oppred rest2)
| SpecOverlap_neq1 f1 T1 oppred1 rest1 spec2 :
    NotInSpec f1 spec2 ->
    (forall t pf, SpecOverlap (rest1 t pf) spec2) ->
    SpecOverlap (Spec_Cons f1 T1 oppred1 rest1) spec2
| SpecOverlap_neq2 f2 T2 oppred2 rest2 spec1 :
    NotInSpec f2 spec1 ->
    (forall t pf, SpecOverlap spec1 (rest2 t pf)) ->
    SpecOverlap spec1 (Spec_Cons f2 T2 oppred2 rest2)
.

(* Tactic to prove AxiomOverlap *)
Ltac prove_axiom_overlap :=
  lazymatch goal with
    | |- AxiomOverlap (specAxiom ?ax_name1 ?ax_tp1 :: ?axioms1)
                      (specAxiom ?ax_name2 ?ax_tp2 :: ?axioms2) =>
      match eval hnf in (Field_dec ax_name1 ax_name2) with
        | left _ =>
          (apply AxiomOverlap_eq
                 || fail "Non-matching types at axiom" ax_name1);
          intros; prove_axiom_overlap
        | right ?neq =>
          ((apply AxiomOverlap_neq1; [ prove_not_in_list | ]) ||
           (apply AxiomOverlap_neq2; [ prove_not_in_list | ]) ||
           fail "The axioms " ax_name1 " and " ax_name2 " appear to be in a different order in the two axioms");
          prove_axiom_overlap
      end
    | |- AxiomOverlap (cons _ _) nil =>
      apply AxiomOverlap_neq1; [ apply in_nil | prove_axiom_overlap ]
    | |- AxiomOverlap nil (cons _ _) =>
      apply AxiomOverlap_neq2; [ apply in_nil | prove_axiom_overlap ]
    | |- AxiomOverlap nil nil =>
      apply AxiomOverlap_base
    | |- AxiomOverlap ?axioms1 ?axioms2 =>
      let axioms1_hnf := (eval hnf in axioms1) in
      let axioms2_hnf := (eval hnf in axioms2) in
      progress (change (AxiomOverlap axioms1_hnf axioms2_hnf)); prove_axiom_overlap
    | |- ?goal => fail "prove_axiom_overlap: not an AxiomOverlap goal: " goal
  end.

(* Tactic to prove spec overlap *)
Ltac prove_spec_overlap :=
  lazymatch goal with
    | |- SpecOverlap (Spec_Cons ?f1 ?T1 ?oppred1 ?rest1)
                     (Spec_Cons ?f2 ?T2 ?oppred2 ?rest2) =>
      lazymatch eval hnf in (Field_dec f1 f2) with
        | left _ =>
          (apply SpecOverlap_eq
                 || fail "Non-matching types or predicates at op" f1
                         ": types: " T1 ", " T2
                         "; predicates: " oppred1 ", " oppred2);
          intros; prove_spec_overlap
        | right ?neq =>
          ((apply SpecOverlap_neq1; [ prove_not_in_spec | intros ]) ||
           (apply SpecOverlap_neq2; [ prove_not_in_spec | intros ]) ||
           fail "The fields " f1 " and " f2 " appear to be in a different order in the two specs");
          prove_spec_overlap
      end
    | |- SpecOverlap (Spec_Cons _ _ _ _) (Spec_Axioms _) =>
      apply SpecOverlap_neq1; [ apply NotInSpec_base | intros; prove_spec_overlap ]
    | |- SpecOverlap (Spec_Axioms _) (Spec_Cons _ _ _ _) =>
      apply SpecOverlap_neq2; [ apply NotInSpec_base | intros; prove_spec_overlap ]
    | |- SpecOverlap (Spec_Axioms _) (Spec_Axioms _) =>
      apply SpecOverlap_base; prove_axiom_overlap
    | |- SpecOverlap ?spec1 ?spec2 =>
      let spec1_hnf := (eval hnf in spec1) in
      let spec2_hnf := (eval hnf in spec2) in
      progress (change (SpecOverlap spec1_hnf spec2_hnf)); prove_spec_overlap
    | |- ?goal => fail "prove_spec_overlap: not a SpecOverlap goal: " goal
  end.

(* Debugging version of the above tactic to prove spec overlap *)
Ltac prove_spec_overlapN n :=
  lazymatch n with
    | 0 => idtac "prove_spec_overlapN: n exhausted"
    | S ?n' =>
      lazymatch goal with
        | |- SpecOverlap (Spec_Cons ?f1 ?T1 ?oppred1 ?rest1)
                         (Spec_Cons ?f2 ?T2 ?oppred2 ?rest2) =>
          idtac "prove_spec_overlapN: cons-cons";
          lazymatch eval hnf in (Field_dec f1 f2) with
            | left _ =>
              (apply SpecOverlap_eq
                     || fail "Non-matching types or predicates at op" f1
                             ": types: " T1 ", " T2
                             "; predicates: " oppred1 ", " oppred2);
              intros; prove_spec_overlapN n'
            | right ?neq =>
              ((apply SpecOverlap_neq1; [ prove_not_in_spec | intros ]) ||
               (apply SpecOverlap_neq2; [ prove_not_in_spec | intros ]) ||
               fail "The fields " f1 " and " f2 " appear to be in a different order in the two specs");
              prove_spec_overlapN n'
          end
        | |- SpecOverlap (Spec_Cons _ _ _ _) (Spec_Axioms _) =>
          idtac "prove_spec_overlapN: cons-axiom";
          apply SpecOverlap_neq1; [ apply NotInSpec_base | intros; prove_spec_overlapN n' ]
        | |- SpecOverlap (Spec_Axioms _) (Spec_Cons _ _ _ _) =>
          idtac "prove_spec_overlapN: axiom-cons";
          apply SpecOverlap_neq2; [ apply NotInSpec_base | intros; prove_spec_overlapN n' ]
        | |- SpecOverlap (Spec_Axioms _) (Spec_Axioms _) =>
          idtac "prove_spec_overlapN: axiom-axiom";
          apply SpecOverlap_base; prove_axiom_overlap
        | |- SpecOverlap ?spec1 ?spec2 =>
          idtac "prove_spec_overlapN: hnf";
          let spec1_hnf := (eval hnf in spec1) in
          let spec2_hnf := (eval hnf in spec2) in
          progress (change (SpecOverlap spec1_hnf spec2_hnf)); prove_spec_overlapN n'
        | |- ?goal => fail "prove_spec_overlapN: not a SpecOverlap goal: " goal
      end
  end.

(*** Spec Substitution ***)

(* Helper for spec_subtract: return all axioms in the axioms1 list that do not
overlap with the axioms in axioms2 *)
Fixpoint axioms_subtract axioms1 axioms2
         (overlap: AxiomOverlap axioms1 axioms2) : list SpecAxiom :=
  match overlap with
    | AxiomOverlap_base => []
    | AxiomOverlap_eq ax_name ax_tp axioms1 axioms2 overlap' =>
      axioms_subtract axioms1 axioms2 overlap'
    | AxiomOverlap_neq1 ax_name ax_tp axioms1' axioms2' not_in overlap' =>
      (specAxiom ax_name ax_tp)
        :: axioms_subtract axioms1' axioms2' overlap'
    | AxiomOverlap_neq2 ax_name ax_tp axioms1' axioms2' not_in overlap' =>
      axioms_subtract axioms1' axioms2' overlap'
  end.

(* If you subtract axioms2 from axioms1 and then add them back again you can
prove the original axioms1. *)
Lemma axioms_subtract_interp axioms1 axioms2 overlap :
  conjoin_axioms axioms2 ->
  conjoin_axioms (axioms_subtract axioms1 axioms2 overlap) ->
  conjoin_axioms axioms1.
  induction overlap; intros.
  trivial.
  destruct (conjoin_axioms_destruct _ _ _ H).
  apply conjoin_axioms_cons; [ assumption | apply IHoverlap; assumption ].
  destruct (conjoin_axioms_destruct _ _ _ H0).
  apply conjoin_axioms_cons; [ assumption | apply IHoverlap; assumption ].
  destruct (conjoin_axioms_destruct _ _ _ H).
  apply IHoverlap; assumption.
Qed.

(* Subtract the overlapping ops and axioms in spec2 from spec1. Note that this
operation requires ops for spec2. *)
Fixpoint spec_subtract spec1 spec2 (overlap: SpecOverlap spec1 spec2) :
  spec_ops spec2 -> Spec :=
  match overlap in SpecOverlap spec1 spec2 return spec_ops spec2 -> Spec with
    | SpecOverlap_base axioms1 axioms2 overlap' =>
      fun _ => Spec_Axioms (axioms_subtract axioms1 axioms2 overlap')
    | SpecOverlap_eq f T oppred rest1 rest2 overlap' =>
      fun ops2 =>
        let (t,pf,ops2') := ops2 in
        spec_subtract (rest1 t pf) (rest2 t pf) (overlap' t pf) ops2'
    | SpecOverlap_neq1 f1 T1 oppred1 rest1 spec2 not_in overlap' =>
      fun ops2 =>
        Spec_Cons f1 T1 oppred1
                    (fun t pf =>
                       spec_subtract (rest1 t pf) spec2 (overlap' t pf) ops2)
    | SpecOverlap_neq2 f2 T2 oppred2 rest2 spec1 not_in overlap' =>
      fun ops2 =>
        let (t,pf,ops2') := ops2 in
        spec_subtract spec1 (rest2 t pf) (overlap' t pf) ops2'
  end.

(* If you subtract spec2 from spec1 then you can recover all the ops of spec1 if
you have ops for spec2 and for the subtraction. This definition, along with
spec_subtract_interp_model, forms a binary sort of interpretation. *)
Fixpoint spec_subtract_interp_ops spec1 spec2 (overlap : SpecOverlap spec1 spec2) :
  forall (ops2:spec_ops spec2),
  spec_ops (spec_subtract spec1 spec2 overlap ops2) ->
  spec_ops spec1 :=
  match overlap in SpecOverlap spec1 spec2
        return forall ops2,
                 spec_ops (spec_subtract spec1 spec2 overlap ops2) ->
                 spec_ops spec1 with
    | SpecOverlap_base axioms1 axioms2 overlap' =>
      fun ops2 ops21 => tt
    | SpecOverlap_eq f T oppred rest1 rest2 overlap' =>
      fun ops2 =>
        match ops2 return
              spec_ops (spec_subtract
                          _ _ (SpecOverlap_eq _ _ _ _ _ overlap') ops2) ->
              spec_ops (Spec_Cons f T oppred rest1) with
          | opCons t pf ops2' =>
            fun ops21 =>
              opCons t pf (spec_subtract_interp_ops _ _ (overlap' t pf) ops2' ops21)
        end
    | SpecOverlap_neq1 f1 T1 oppred1 rest1 spec2 not_in overlap' =>
      fun ops2 ops21 =>
        match ops21 return spec_ops (Spec_Cons f1 T1 oppred1 rest1) with
          | opCons t pf ops21' =>
            opCons t pf (spec_subtract_interp_ops _ _ (overlap' t pf) ops2 ops21')
        end
    | SpecOverlap_neq2 f2 T2 oppred2 rest2 spec1 not_in overlap' =>
      fun ops2 =>
        match ops2 return
              spec_ops (spec_subtract
                          _ _ (SpecOverlap_neq2 _ _ _ _ _ _ overlap') ops2) ->
              spec_ops spec1 with
          | opCons t pf ops2' =>
            fun ops21 =>
              spec_subtract_interp_ops _ _ (overlap' t pf) ops2' ops21
        end
  end.

(* If you subtract spec2 from spec1 then you can recover a model of spec1 if you
have a model for spec2 and for the subtraction. This definition, along with
spec_subtract_interp_ops, forms a binary sort of interpretation. *)
Lemma spec_subtract_interp_model spec1 spec2 (overlap : SpecOverlap spec1 spec2) :
  forall (ops2:spec_ops spec2) (model2:spec_model spec2 ops2)
         (ops21:spec_ops (spec_subtract spec1 spec2 overlap ops2))
         (model21:spec_model (spec_subtract spec1 spec2 overlap ops2) ops21),
    spec_model spec1 (spec_subtract_interp_ops spec1 spec2 overlap ops2 ops21).
  induction overlap; intros.
  apply (axioms_subtract_interp axioms1 axioms2 a); assumption.
  destruct ops2 as [t pf ops2'].
  apply H; assumption.
  destruct ops21 as [t pf ops21'].
  apply H; assumption.
  destruct ops2 as [t pf ops2'].
  apply H; assumption.
Qed.

(* Build a spec using spec substitution *)
Definition spec_subst {spec spec1 spec2}
           (overlap: SpecOverlap spec spec1) (i: Interpretation spec1 spec2) : Spec :=
  spec_append spec2
              (fun ops2 =>
                 spec_subtract spec spec1 overlap (map_ops i ops2)).

(* Build the interpretation from spec1 to the result of applying spec
substitution to spec1 *)
Definition spec_subst_interp1 {spec spec1 spec2} overlap i :
  Interpretation spec (@spec_subst spec spec1 spec2 overlap i).
  unfold spec_subst.
  eapply interp_append; intros.
  apply spec_subtract_interp_model.
  apply (map_model i _ H).
  apply H0.
Defined.

(* Build the interpretation from spec2 to the result of applying any spec
substitution using an interpretation into spec2 *)
Definition spec_subst_interp2 {spec spec1 spec2} overlap i :
  Interpretation spec2 (@spec_subst spec spec1 spec2 overlap i) :=
  interp_append1 _ _.

(*** Quantifying over the Ops of a Spec ***)

Definition ForallOp T (oppred: OpPred T) : (forall t, oppred t -> Type) -> Type :=
  match oppred return (forall t, sats_op_pred oppred t -> Type) -> Type with
    | Pred_Trivial => fun A => forall t, A t I
    | _ => fun A => forall t pf, A t pf
  end.

Definition LambdaOp T oppred : forall body_tp, (forall t pf, body_tp t pf) ->
                                               ForallOp T oppred body_tp :=
  match oppred return forall body_tp, (forall t pf, body_tp t pf) ->
                                      ForallOp T oppred body_tp with
    | Pred_Trivial => fun body_tp body => fun t => body t I
    | _ => fun body_tp body => fun t pf => body t pf
  end.

Definition replace_op_proof T (oppred: OpPred T) : forall t, oppred t -> oppred t :=
  match oppred return forall t, sats_op_pred oppred t ->
                                sats_op_pred oppred t with
    | Pred_Trivial => fun t _ => I
    | _ => fun t pf => pf
  end.

(* Helper: all proofs of True are equal *)
Definition True_eq (pf1: True) : forall pf2, pf1 = pf2 :=
  match pf1 return forall pf2, pf1 = pf2 with
    | I => fun pf2 => match pf2 return I = pf2 with I => eq_refl end end.

(* Helper: all elements of unit are equal *)
Definition unit_eq (u1: unit) : forall u2, u1 = u2 :=
  match u1 return forall u2, u1 = u2 with
    | tt => fun u2 => match u2 return tt = u2 with tt => eq_refl end end.

(* Replacing an op proof yields an equal proof (because a proof of True is a
proof of True) *)
Definition replace_op_proof_eq T (oppred: OpPred T) :
  forall t pf, pf = replace_op_proof T oppred t pf :=
  match oppred return forall t pf, pf = replace_op_proof T oppred t pf with
    | Pred_Trivial => fun t _ => True_eq _ _
    | _ => fun t pf => eq_refl
  end.

(* Apply an op function to an op and its proof *)
Definition ApplyOp T (oppred: OpPred T) :
  forall body_tp, ForallOp T oppred body_tp ->
                  forall t pf, body_tp t (replace_op_proof T oppred t pf) :=
  match oppred return forall body_tp,
                        ForallOp T oppred body_tp ->
                        forall t pf, body_tp t (replace_op_proof T oppred t pf) with
    | Pred_Trivial => fun body_tp body t pf => body t
    | _ => fun body_tp body t pf => body t pf
  end.

(* The type of Curried functions on the ops of spec *)
Fixpoint ForallOps spec : (spec_ops spec -> Type) -> Type :=
  match spec with
    | Spec_Axioms _ => fun body_tp => body_tp tt
    | Spec_Cons f T oppred rest =>
      fun body_tp =>
        ForallOp T oppred
                 (fun t pf => ForallOps (rest t pf)
                                        (fun ops => body_tp (opCons t pf ops)))
  end.

(* The type of Curried predicates on the ops of spec *)
Definition OpsPred spec : Type := ForallOps spec (fun _ => Prop).

(* Build a ForallOps function *)
Fixpoint LambdaOps spec : forall body_tp, (forall ops, body_tp ops) ->
                                          ForallOps spec body_tp :=
  match spec return forall body_tp, (forall ops, body_tp ops) ->
                                    ForallOps spec body_tp with
    | Spec_Axioms _ =>
      fun body_tp body => body tt
    | Spec_Cons f T oppred rest =>
      fun body_tp body =>
        LambdaOp T oppred _
                 (fun t pf =>
                    LambdaOps (rest t pf) _ (fun ops => body (opCons t pf ops)))
  end.

(* Replace all the trivial True proofs in a spec_ops with I *)
Fixpoint replace_op_proofs spec : spec_ops spec -> spec_ops spec :=
  match spec with
    | Spec_Axioms _ => fun ops => ops
    | Spec_Cons f T oppred rest =>
      fun ops =>
        opCons (ops_head ops)
                 (replace_op_proof T oppred _ (ops_proof ops))
                 (replace_op_proofs (rest _ _)
                                    (rew [fun pf => spec_ops (rest _ pf)]
                                         replace_op_proof_eq T oppred _ _
                                         in (ops_rest ops)))
  end.

(* Replacing all the trivial proofs yields an equal ops list *)
Lemma replace_op_proofs_eq spec ops : replace_op_proofs spec ops = ops.
  induction spec.
  reflexivity.
  unfold replace_op_proofs; fold replace_op_proofs.
  destruct ops as [t pf ops].
  unfold ops_head; unfold ops_proof; unfold ops_rest.
  destruct oppred; unfold replace_op_proof; unfold replace_op_proof_eq;
    rewrite H; unfold eq_rect;
    [ destruct pf | | ]; reflexivity.
Qed.

(* Apply a Curried predicate to some candidate ops for spec *)
Fixpoint ApplyOps spec : forall A, (ForallOps spec A) ->
                                   forall ops, A (replace_op_proofs spec ops) :=
  match spec return forall A, (ForallOps spec A) ->
                              forall ops, A (replace_op_proofs spec ops) with
    | Spec_Axioms _ =>
      fun A body ops => rew [A] (unit_eq _ _) in body
    | Spec_Cons f T oppred rest =>
      fun A body ops =>
        ApplyOps
          (rest (ops_head ops)
                (replace_op_proof T oppred _ (ops_proof ops)))
          (fun ops => A (opCons _ _ ops))
          (ApplyOp T oppred _ body (ops_head ops) (ops_proof ops))
          (rew [fun pf => spec_ops (rest _ pf)]
               replace_op_proof_eq T oppred _ _ in ops_rest ops)
  end.

(*** Types / Typeclasses Represented by Specs ***)

(* FIXME: remove IsoToSpec and IsoInterpretation, and possibly ForallOps *)

(* Whether P is isomorphic to spec *)
Class IsoToSpec spec (P: OpsPred spec) : Prop :=
  spec_iso: forall ops, ApplyOps spec _ P ops <-> spec_model spec ops.

(* An IsoInterpretation is an interpretation between type classes / type
functions that are isomorphic to specs *)
Definition IsoInterpretation {spec1 P1} (iso1: IsoToSpec spec1 P1)
           {spec2 P2} (iso2: IsoToSpec spec2 P2)
           (ops_f: spec_ops spec2 -> spec_ops spec1) : Type :=
  ForallOps spec2 (fun ops2 => ApplyOps spec2 _ P2 ops2 ->
                               ApplyOps spec1 _ P1 (ops_f ops2)).

(* Turn an interpretation from spec1 to spec2 into a function from a predicate
isomorphic to spec2 to a predicate ismorphic to spec1 *)
Definition toIsoInterp {spec1 P1} {iso1: IsoToSpec spec1 P1}
           {spec2 P2} {iso2: IsoToSpec spec2 P2}
           (i: Interpretation spec1 spec2) :
  IsoInterpretation iso1 iso2 (map_ops i) :=
  LambdaOps spec2 _ (fun ops2 p2 =>
                       proj2 (spec_iso (map_ops i ops2))
                             (map_model i ops2 (proj1 (spec_iso ops2) p2))).

(* Turn an IsoInterpretation into an Interpretation *)
Definition fromIsoInterp {spec1 P1} {iso1: IsoToSpec spec1 P1}
           {spec2 P2} {iso2: IsoToSpec spec2 P2} {ops_f}
           (i: IsoInterpretation iso1 iso2 ops_f) :
  Interpretation spec1 spec2 :=
  mkInterp ops_f (fun ops2 model2 =>
                    proj1 (spec_iso (ops_f ops2))
                          (rew [fun ops => ApplyOps spec1 _ P1 (ops_f ops)]
                               (replace_op_proofs_eq _ _)
                            in ApplyOps _ _ i ops2
                                        (rew [ApplyOps spec2 _ P2]
                                             (eq_sym (replace_op_proofs_eq _ _))
                                          in proj2 (spec_iso ops2) model2))).

(*** Examples of Isomorphic Interpretations ***)

(* Tactic to prove IsoToSpec instances *)
Ltac prove_spec_iso :=
  intro ops;
  repeat (let t := fresh "t" in
          let pf := fresh "pf" in
          destruct ops as [t ops]; destruct ops as [pf ops];
          try destruct pf);
  destruct ops; split; compute;
  [ intro H; destruct H;
    repeat (first [ assumption | split; [assumption|] | apply I])
  | intro H; repeat (let Hi := fresh "H" in
                     destruct H as [Hi H]); constructor; assumption ].

(* Example 1:  op n:nat;  axiom gt1: n > 1 *)
Class spec_example_1_class (n:nat) : Prop :=
  { example_1__gt1 : n > 1 }.

(* Isomorphism between spec_example_1 and spec_example_1_class *)
(*
Instance iso_example_1 : IsoToSpec spec_example_1 spec_example_1_class.
prove_spec_iso.
Qed.
*)

(* Example 2:  op n:nat := 2;  (no axioms) *)
Class spec_example_2_class (n:nat) (n__pf: n = 2) : Prop := { }.

(*
Instance iso_example_2 : IsoToSpec spec_example_2 spec_example_2_class.
prove_spec_iso.
Qed.
*)

(* Example 3:  op T:Set := nat;  op n:T__def;  axiom gt1: n > 1 *)
Class spec_example_3_class (T:Set) (T__pf: T = nat) (n: def T T__pf) : Prop :=
  { example_3__gt1 : n > 1 }.

(*
Instance iso_example_3 : IsoToSpec spec_example_3 spec_example_3_class.
prove_spec_iso.
Qed.
*)

(* Example: lift the spec3 -> spec2 interpretation to an instance function *)
(*
Instance iso_interp_example_3_2 : forall `{spec_example_2_class}, spec_example_3_class _ _ _ :=
  toIsoInterp (interp_example_3_2).
*)

(* Example 4: monoids *)
Class Monoid {T:Set} {m_zero:T} {m_plus:T -> T -> T} : Prop :=
  {m_zero_left : (forall x, m_plus m_zero x = x);
   m_zero_right : (forall x, m_plus x m_zero = x);
   m_plus_assoc : (forall x y z, m_plus x (m_plus y z) = m_plus (m_plus x y) z)}.

(*
Instance iso_example_monoid : IsoToSpec spec_example_monoid (@Monoid).
prove_spec_iso.
Qed.
*)

(* Example 4: groups *)
Class Group {T:Set} {g_zero:T} {g_plus:T -> T -> T} {g_inv:T -> T} : Prop :=
  {g_zero_left : (forall x, g_plus g_zero x = x);
   g_zero_right : (forall x, g_plus x g_zero = x);
   g_plus_assoc : (forall x y z, g_plus x (g_plus y z) = g_plus (g_plus x y) z);
   g_inv_left : (forall (x:T), g_plus (g_inv x) x = g_zero);
   g_inv_right : (forall (x:T), g_plus x (g_inv x) = g_zero)}.

(*
Instance iso_example_group : IsoToSpec spec_example_group (@Group).
prove_spec_iso.
Qed.
*)

(* Interpretation from Monoid to Group type classes *)
Program Instance group_as_monoid `{Group} :
  Monoid (m_zero:=g_zero) (m_plus:=g_plus).
Next Obligation. apply g_zero_left. Qed.
Next Obligation. apply g_zero_right. Qed.
Next Obligation. apply g_plus_assoc. Qed.

(*
NOTE: the below loops forever!

Check (@group_as_monoid : IsoInterpretation iso_example_monoid iso_example_group _).
Check (fromIsoInterp (iso1:=iso_example_monoid)
                     (iso2:=iso_example_group)
                     (@group_as_monoid)).
*)

(*** An Alternative Isomorphism to Specs ***)

Class IsoToSpecModels {spec} (ops: spec_ops spec) (P: Prop) : Prop :=
  spec_models_iso : P <-> spec_model spec ops.

(* Tactic to prove IsoToSpec instances *)
Ltac prove_spec_models_iso :=
  split; compute;
  [ intro H; destruct H;
    repeat (first [ assumption | split; [assumption|] | apply I])
  | intro H; repeat (let Hi := fresh "H" in
                     destruct H as [Hi H]); constructor; assumption ].

(*** Spec Translations ***)

(* A spec translation element, which denotes either a single mapping from field
f_from to field f_to, or a set of mappings from fields with prefix f_from_prefix
to the result of replacing that prefix with f_to_prefix. *)
Inductive SpecTranslationElem : Set :=
| XlateSingle (f_from f_to : Field)
| XlatePrefix (f_from_prefix f_to_prefix : string)
.

Arguments XlateSingle (f_from%string) (f_to%string).
Arguments XlatePrefix (f_from_prefix%string) (f_to_prefix%string).

(* A spec translation is just a list of spec translation elements *)
Inductive SpecTranslation : Set :=
| mkSpecTranslation (elems: list SpecTranslationElem).

Notation "f_from '+->' f_to" :=
  (XlateSingle f_from f_to)
  (at level 80, no associativity) : spec_translation_elem_scope.
Notation "f_from '%' '+->' f_to '%'" :=
  (XlatePrefix f_from f_to)
  (at level 80, no associativity) : spec_translation_elem_scope.

Bind Scope spec_translation_elem_scope with SpecTranslationElem.
Delimit Scope spec_translation_elem_scope with spec_translation_elem.

(* We use double curly brackets to write spec translations *)
Notation "'{' elem1 , .. , elemn '}'" :=
  (mkSpecTranslation (cons elem1%spec_translation_elem .. (cons elemn%spec_translation_elem nil) ..))
  (at level 0) : spec_translation_scope.
Notation "'{' '}'" :=
  (mkSpecTranslation nil)
  (at level 0) : spec_translation_scope.

Bind Scope spec_translation_scope with SpecTranslation.
Delimit Scope spec_translation_scope with spec_translation.

Definition translate_field1 elem (f: Field) : option Field :=
  match elem with
    | XlateSingle f_from f_to =>
      if Field_dec f f_from then Some f_to else None
    | XlatePrefix f_from_prefix f_to_prefix =>
      if Field_dec (substring 0 (length f_from_prefix) f) f_from_prefix then
        Some (append f_to_prefix (substring (length f_from_prefix)
                                            (length f - length f_from_prefix) f))
      else None
  end.

Definition translate_field xlate f : Field :=
  match xlate with
    | mkSpecTranslation elems =>
      fold_right (fun elem rec =>
                    match translate_field1 elem f with
                      | Some f' => f'
                      | None => rec
                    end) f elems
  end.

Definition translate_spec_axioms xlate axioms : list SpecAxiom :=
  map (fun ax =>
         match ax with
           | specAxiom f P => specAxiom (translate_field xlate f) P
         end) axioms.

Fixpoint translate_spec xlate spec : Spec :=
  match spec with
    | Spec_Axioms axioms =>
      Spec_Axioms (translate_spec_axioms xlate axioms)
    | Spec_Cons f T oppred rest =>
      Spec_Cons (translate_field xlate f) T oppred
                  (fun x x__pf => translate_spec xlate (rest x x__pf))
  end.

(* NOTE: the spec_ops type of a translated spec is in fact equal to that of the
original spec, but this requires functional extensionality to prove... *)

Fixpoint translate_spec_ops xlate spec :
  spec_ops (translate_spec xlate spec) -> spec_ops spec :=
  match spec return spec_ops (translate_spec xlate spec) -> spec_ops spec with
    | Spec_Axioms _ => fun ops => ops
    | Spec_Cons f T oppred rest =>
      fun ops =>
        match ops with
          | opCons t pf ops' =>
            opCons t pf (translate_spec_ops xlate _ ops')
        end
  end.

Lemma translate_spec_axioms_impl xlate axioms :
  conjoin_axioms (translate_spec_axioms xlate axioms) -> conjoin_axioms axioms.
  induction axioms.
  intro; assumption.
  destruct axioms; destruct a.
  intro; assumption.
  intro H; destruct H; split.
  assumption.
  apply IHaxioms; assumption.
Defined.

(* Build an interpretation from spec to (translate_spec xlate spec) *)
Program Definition interp_translate_spec xlate spec :
  Interpretation spec (translate_spec xlate spec) :=
  mkInterp (translate_spec_ops xlate spec) _.
Next Obligation.
revert ops H; induction spec; intros.
apply (translate_spec_axioms_impl xlate); assumption.
destruct ops as [t pf ops].
apply H. assumption.
Defined.

(* Reverse the translation of spec ops *)
Fixpoint untranslate_spec_ops xlate spec :
  spec_ops spec -> spec_ops (translate_spec xlate spec) :=
  match spec return spec_ops spec -> spec_ops (translate_spec xlate spec) with
    | Spec_Axioms _ => fun ops => ops
    | Spec_Cons f T oppred rest =>
      fun ops =>
        match ops with
          | opCons t pf ops' =>
            opCons t pf (untranslate_spec_ops xlate _ ops')
        end
  end.

Lemma untranslate_spec_axioms_impl xlate axioms :
  conjoin_axioms axioms -> conjoin_axioms (translate_spec_axioms xlate axioms).
  induction axioms.
  intro; assumption.
  destruct axioms; destruct a.
  intro; assumption.
  intro H; destruct H; split.
  assumption.
  apply IHaxioms; assumption.
Defined.

(* Build an interpretation from (translate_spec xlate spec) back to spec *)
Program Definition interp_untranslate_spec xlate spec :
  Interpretation (translate_spec xlate spec) spec :=
  mkInterp (untranslate_spec_ops xlate spec) _.
Next Obligation.
revert ops H; induction spec; intros.
apply (untranslate_spec_axioms_impl xlate); assumption.
destruct ops as [t pf ops].
apply H. assumption.
Defined.

(* Translate an interpretation *)
Definition translate_interp {spec1 spec2} xlate
           (i: Interpretation spec1 spec2) :
  Interpretation (translate_spec xlate spec1) (translate_spec xlate spec2) :=
  interp_compose (interp_translate_spec xlate spec2)
                 (interp_compose i (interp_untranslate_spec xlate spec1)).

(***
 *** Building Interprations using Translations
 ***)

(* Like interp_cons, but allow the head op name to be translated and the head op
predicate to be strengthened *)
Definition interp_cons_strengthen_xlate xlate f1 T (oppred1 oppred2: OpPred T)
           {spec1 spec2}
           (impl: forall t, oppred2 t -> oppred1 t)
           (i: forall t pf2,
                 Interpretation (spec1 t (impl t pf2)) (spec2 t pf2)) :
  Interpretation (Spec_Cons f1 T oppred1 spec1)
                 (Spec_Cons (translate_field xlate f1) T oppred2 spec2) :=
  mkInterp (fun ops2:spec_ops (Spec_Cons (translate_field xlate f1)
                                           T oppred2 spec2) =>
              let (t,pf,ops2') := ops2 in
              opCons t (impl _ pf) (map_ops (i t pf) ops2')
              : spec_ops (Spec_Cons _ _ _ _))
           (fun ops2 =>
              match ops2
                    return spec_model (Spec_Cons (translate_field xlate f1)
                                                   T oppred2 spec2) ops2 ->
                           spec_model
                             (Spec_Cons f1 T oppred1 spec1)
                             (let (t,pf,ops2') := ops2 in
                              opCons t (impl t pf) (map_ops (i _ _) ops2')) with
                | opCons t pf ops2' =>
                  fun model2 =>
                    map_model (i t pf) ops2' model2
              end).

(* Similar to the above, but substitute the definition of an op that is defined
in the co-domain into the domain spec *)
Definition interp_cons_def_xlate xlate f1 T (oppred1: OpPred T) t2
           {spec1: forall t, oppred1 t -> Spec} {spec2}
           (oppred1_pf: oppred1 t2)
           (i: forall t pf2,
                 Interpretation (spec1 t2 oppred1_pf) (spec2 t pf2)) :
  Interpretation (Spec_Cons f1 T oppred1 spec1)
                 (Spec_Cons (translate_field xlate f1) T (Pred_Eq t2) spec2) :=
  mkInterp (fun ops2:spec_ops (Spec_Cons (translate_field xlate f1)
                                           T (Pred_Eq t2) spec2) =>
              let (t,pf,ops2') := ops2 in
              opCons t2 oppred1_pf (map_ops (i t pf) ops2')
              : spec_ops (Spec_Cons _ _ _ _))
           (fun ops2 =>
              match ops2
                    return spec_model (Spec_Cons (translate_field xlate f1)
                                                   T (Pred_Eq t2) spec2) ops2 ->
                           spec_model
                             (Spec_Cons f1 T oppred1 spec1)
                             (let (t,pf,ops2') := ops2 in
                              opCons t2 oppred1_pf (map_ops (i _ _) ops2')) with
                | opCons t pf ops2' =>
                  fun model2 =>
                    map_model (i t pf) ops2' model2
              end).

(* Similar to the above, but allow the field types to be provably, not just
definitionally, equal *)
Definition interp_cons_strengthen_xlate_eq xlate f1 T1 T2 (oppred1: OpPred T1)
           (oppred2: OpPred T2)
           {spec1: forall t, oppred1 t -> Spec} {spec2}
           (eT: T2 = T1) (impl: forall t, oppred2 t -> oppred1 (rew eT in t))
           (i: forall t pf2,
                 Interpretation (spec1 (rew eT in t) (impl t pf2)) (spec2 t pf2)) :
  Interpretation (Spec_Cons f1 T1 oppred1 spec1)
                 (Spec_Cons (translate_field xlate f1) T2 oppred2 spec2) :=
  mkInterp (fun ops2:spec_ops (Spec_Cons (translate_field xlate f1)
                                           T2 oppred2 spec2) =>
              let (t,pf,ops2') := ops2 in
              opCons (rew eT in t) (impl _ pf) (map_ops (i t pf) ops2')
              : spec_ops (Spec_Cons _ _ _ _))
           (fun ops2 =>
              match ops2
                    return spec_model (Spec_Cons (translate_field xlate f1)
                                                   T2 oppred2 spec2) ops2 ->
                           spec_model
                             (Spec_Cons f1 T1 oppred1 spec1)
                             (let (t,pf,ops2') := ops2 in
                              opCons (rew eT in t) (impl t pf)
                                     (map_ops (i _ _) ops2')) with
                | opCons t pf ops2' =>
                  fun model2 =>
                    map_model (i t pf) ops2' model2
              end).

(* Tactic to prove a "simple" interpretation, which is one where none of the ops
have to be re-ordered, but where the fields can be translated between the domain
spec and the co-domain spec. *)
Ltac try_prove_simple_interp_pred :=
  try assumption; try apply I.
Ltac intros_for_cons_op f oppred :=
  (* FIXME: wish I could convert f to an id... *)
  let f_var := fresh "t" in
  let f_pf_var := fresh "pf" in
  intros f_var f_pf_var;
  (* (lazymatch oppred with
     | Pred_Eq _ =>
       rewrite f_pf_var
     | _ => idtac
   end) *)
  idtac.
Ltac prove_simple_interp xlate :=
  let next :=
      lazymatch goal with
      | |- Interpretation (Spec_Cons ?f1 ?T1 ?oppred1 ?rest1)
                          (Spec_Cons ?f2 ?T2 ?oppred2 ?rest2) =>
        lazymatch (eval cbn in (Field_dec f2 (translate_field xlate f1))) with
          | left _ =>
            first
              [ apply (interp_cons_def_xlate xlate);
                [ intros; try_prove_simple_interp_pred
                | intros_for_cons_op f2 oppred2; prove_simple_interp xlate ]
              | apply (interp_cons_strengthen_xlate xlate);
                [ intros; try_prove_simple_interp_pred
                | intros_for_cons_op f2 oppred2; prove_simple_interp xlate ]
              | (eapply (interp_cons_strengthen_xlate_eq
                           xlate f1 T1 T2 oppred1 oppred2);
                 [ intros; try_prove_simple_interp_pred
                 | intros_for_cons_op f2 oppred2; prove_simple_interp xlate ]) ]
          | right _ =>
            apply interp_cons_r; intros; prove_simple_interp xlate
        end
      | |- Interpretation (Spec_Axioms _)
                          (Spec_Cons ?f2 ?T2 ?oppred2 ?rest2) =>
        apply interp_cons_r; intros_for_cons_op f2 oppred2;
        prove_simple_interp xlate
      | |- Interpretation (Spec_Axioms _) (Spec_Axioms _) =>
        idtac "axioms";
        apply (mkInterp (fun _ => tt : spec_ops (Spec_Axioms _)));
        intros ops model; unfold spec_model, conjoin_axioms in model;
        repeat (let ax_name := fresh "axiom" in
                first [ destruct model as [ax_name model]
                      | rename model into ax_name ]);
        unfold spec_model, conjoin_axioms; repeat split;
        try assumption
      | |- Interpretation ?S1 ?S2 =>
        let S1' := (eval hnf in S1) in
        let S2' := (eval hnf in S2) in
        (progress (change S1 with S1'; change S2 with S2');
         prove_simple_interp xlate)
          || (* fail *) idtac "Cannot prove this interpretation!"
      end
    in
      next
.

(* Old version *)
(*
Ltac prove_simple_interp xlate :=
  repeat (first [apply (interp_cons_strengthen_xlate xlate);
                  intros; [ try assumption | ]
                | apply interp_cons_r; intros ]);
  apply (mkInterp (fun _ => tt : spec_ops (Spec_Axioms _))); intros ops model;
  unfold spec_model, conjoin_axioms, specAxiom, snd in model;
  repeat (let ax_name := fresh "axiom" in
          first [ destruct model as [ax_name model] | rename model into ax_name ]);
  unfold spec_model, conjoin_axioms, specAxiom, snd; repeat split;
  try assumption.
*)

(* For proving the model part of an interpretation given by an interp_map *)
Ltac interp_tactic :=
  intros;
  lazymatch goal with
    | |- spec_model ?dom_spec (let (rest, t) := ?ops in ?body) =>
      destruct ops as [t ops]
    | |- Pred_Trivial _ => apply I
    | |- Pred_Fun _ => try assumption
    | |- _ => try (apply I); try assumption
  end.

(*** Refinement ***)

(* Helper wrapper around the refine tactic *)
Ltac specware_refine arg := refine arg.

(* A refinement import into spec is some spec', an interpretation from spec' to
spec, and a type that is isomorphic to spec' *)
Record RefinementImport spec : Type :=
  {ref_import_fromspec: Spec;
   ref_import_interp: Interpretation ref_import_fromspec spec}.

(* A refinement of spec is some ref_spec, an interpretation from spec to
ref_spec, and a list of refinement imports for ref_spec *)
Record RefinementOf spec : Type :=
  {ref_spec: Spec;
   ref_interp: Interpretation spec ref_spec;
   ref_imports: list (RefinementImport ref_spec)}.

(* The identity refinement of a spec to itself, with no other specs *)
Definition id_refinement_noimport spec : RefinementOf spec :=
  {| ref_spec := spec;
     ref_interp := interp_id spec;
     ref_imports := [] |}.

(* Add a refinement import to a refinement *)
Definition refinement_add_import {spec} (R: RefinementOf spec) :
  RefinementImport (ref_spec _ R) -> RefinementOf spec :=
  match R as R return RefinementImport (ref_spec _ R) -> RefinementOf spec with
    | Build_RefinementOf _ s i imps =>
      fun (imp:RefinementImport s) => Build_RefinementOf _ s i (imp::imps)
  end.

(* Get the nth import of a RefinementOf, returning the identity if n is too big *)
Definition nth_refinement_import {spec} (R: RefinementOf spec) n :
  n < List.length (ref_imports _ R) -> RefinementImport (ref_spec _ R) :=
  nth_nodef n (ref_imports _ R).

(* The identity refinement with an import *)
Definition id_refinement spec : RefinementOf spec :=
  {| ref_spec := spec;
     ref_interp := interp_id spec;
     ref_imports := [ {| ref_import_fromspec := spec;
                           ref_import_interp := interp_id spec |} ] |}.

(* Compose an interpretation with a refinement import *)
Definition refinement_import_interp {spec spec'}
           (imp: RefinementImport spec)
           (i: Interpretation spec spec') : RefinementImport spec' :=
  match imp with
    | Build_RefinementImport _ fromspec interp =>
      Build_RefinementImport _ fromspec (interp_compose i interp)
  end.

(* Compose an interpretation with a refinement *)
Definition refinement_interp {spec spec'}
           (R: RefinementOf spec) :
  Interpretation (ref_spec _ R) spec' -> RefinementOf spec :=
  match R as R return Interpretation (ref_spec _ R) spec' ->
                      RefinementOf spec with
    | Build_RefinementOf _ s interp imps =>
      fun (i:Interpretation s spec') =>
        Build_RefinementOf _ spec' (interp_compose i interp)
                           (map (fun imp => refinement_import_interp imp i) imps)
  end.

(* Compose two refinements together *)
Definition refinement_compose {spec}
           (R1: RefinementOf spec) :
  RefinementOf (ref_spec spec R1) -> RefinementOf spec :=
  match R1 as R1 return RefinementOf (ref_spec spec R1) ->
                        RefinementOf spec with
    | Build_RefinementOf _ spec1 interp1 imps1 =>
      fun (R2: RefinementOf spec1) =>
        match R2 with
          | Build_RefinementOf _ spec2 interp2 imps2 =>
            {| ref_spec := spec2;
               ref_interp := interp_compose interp2 interp1;
               ref_imports :=
                 (map (fun imp => refinement_import_interp imp interp2) imps1)
                   ++ imps2 |}
        end
  end.

(* Apply a spec substitution to a refinement *)
Definition refinement_subst_noimport {spec spec1 spec2}
           (R: RefinementOf spec) (overlap: SpecOverlap (ref_spec _ R) spec1)
           (i: Interpretation spec1 spec2) : RefinementOf spec :=
  refinement_interp R (spec_subst_interp1 overlap i).

(* Apply a spec substitution to a refinement, importing the co-domain spec *)
Definition refinement_subst {spec spec1 spec2}
           (R: RefinementOf spec) (i: Interpretation spec1 spec2) :
  SpecOverlap (ref_spec _ R) spec1 -> RefinementOf spec :=
  match R as R return SpecOverlap (ref_spec _ R) spec1 -> RefinementOf spec with
    | Build_RefinementOf _ spec' interp imps =>
      fun (overlap: SpecOverlap spec' spec1) =>
        {| ref_spec := spec_subst overlap i;
           ref_interp := interp_compose (spec_subst_interp1 overlap i) interp;
           ref_imports :=
             {| ref_import_fromspec := spec2;
                ref_import_interp := spec_subst_interp2 overlap i |}
               ::(map (fun imp => refinement_import_interp
                                    imp (spec_subst_interp1 overlap i)) imps) |}
  end.

(* FIXME: document this *)
Definition spec_subst_interp2_xlate {spec1sub spec1 spec2}
           xlate (overlap: SpecOverlap spec1 (translate_spec xlate spec1sub))
           (i: Interpretation spec1sub spec2) :
  Interpretation spec2 (spec_subst overlap (translate_interp xlate i)) :=
 interp_compose (interp_append1 _ _) (interp_translate_spec _ _).

(* Apply a spec substitution to a refinement, using the translation of an
interpretation, importing the un-translated co-domain of the interpretation *)
Definition refinement_subst_xlate {spec spec1 spec2}
           (R: RefinementOf spec) (i: Interpretation spec1 spec2) xlate :
  SpecOverlap (ref_spec _ R) (translate_spec xlate spec1) -> RefinementOf spec :=
  match R as R return SpecOverlap (ref_spec _ R) (translate_spec xlate spec1) ->
                      RefinementOf spec with
    | Build_RefinementOf _ spec' interp imps =>
      fun (overlap: SpecOverlap spec' (translate_spec xlate spec1)) =>
        {| ref_spec := spec_subst overlap (translate_interp xlate i);
           ref_interp :=
             interp_compose (spec_subst_interp1
                               overlap (translate_interp xlate i)) interp;
           ref_imports :=
             {| ref_import_fromspec := spec2;
                ref_import_interp := spec_subst_interp2_xlate xlate overlap i |}
               ::(map (fun imp => refinement_import_interp
                                    imp (spec_subst_interp1
                                           overlap (translate_interp xlate i))) imps) |}
  end.

(* Translate a refinement *)
Definition refinement_translate {spec}
           (R: RefinementOf spec) xlate : RefinementOf spec :=
  refinement_interp R (interp_translate_spec xlate _).


From Undecidability.L.Tactics Require Import LTactics.
From Undecidability.L Require Import UpToC.
From Undecidability.L Require Import Functions.EqBool.

From Undecidability.L.Datatypes Require Export List.List_enc LBool LOptions LNat.

Set Default Proof Using "Type".

Section Fix_X.
  Variable (X:Type).
  Context {intX : registered X}.

  Fixpoint inb eqb (x:X) (A: list X) :=
    match A with
      nil => false
    | a::A' => orb (eqb a x) (inb eqb x A')
    end.

  Variable X_eqb : X -> X -> bool.
  Hypothesis X_eqb_spec : (forall (x y:X), Bool.reflect (x=y) (X_eqb x y)).

  Lemma inb_spec: forall x A, Bool.reflect (In x A) (inb X_eqb x A).
  Proof using X_eqb_spec.
    intros x A. induction A.
    -constructor. tauto.
    -simpl. destruct (X_eqb_spec a x).
    +constructor. tauto.
    +inv IHA. destruct (X_eqb_spec a x).
      *constructor. tauto.
      *constructor. tauto.
      *constructor. tauto.
  Qed.

  Global Instance term_inb: computableTime' inb (fun eq eqT => (5,fun x _ => (1,fun l _ =>
                                        (fold_right (fun x' res => callTime2 eqT x' x
                                                                + res + 17) 4 l ,tt)))).
  Proof.
    extract.
    solverec.
  Defined. (*because other extract*)

  Global Instance term_inb_notime: computable inb.
  Proof.
    extract.
  Defined. (*because other extract*)

End Fix_X.

Section list_eqb.

  Variable X : Type.
  Variable eqb : X -> X -> bool.
  Variable spec : forall x y, reflect (x = y) (eqb x y).

  Fixpoint list_eqb A B :=
    match A,B with
    | nil,nil => true
    | a::A',b::B' => eqb a b && list_eqb A' B'
    | _,_ => false
    end.

  Lemma list_eqb_spec A B : reflect (A = B) (list_eqb A B).
  Proof using spec.
    revert B; induction A; intros; destruct B; cbn in *; try now econstructor.
    destruct (spec a x), (IHA B); cbn; econstructor; congruence.
  Qed.

End list_eqb.

Section int.

  Context {X : Type}.
  Context {HX : registered X}.

  Fixpoint list_eqbTime (eqbT: timeComplexity (X -> X -> bool)) (A B:list X) :=
    match A,B with
      a::A,b::B => callTime2 eqbT a b + 22 + list_eqbTime eqbT A B
    | _,_ => 9
    end.

  Global Instance term_list_eqb : computableTime' (list_eqb (X:=X))
                                                  (fun _ eqbT => (1,(fun A _ => (5,fun B _ => (list_eqbTime eqbT A B,tt))))).
  Proof.
    extract.
    solverec.
  Qed.

  Global Instance term_list_eqb_notime : computable(list_eqb (X:=X)).
  Proof.
    extract.
  Defined.

  Definition list_eqbTime_leq (eqbT: timeComplexity (X -> X -> bool)) (A B:list X) k:
    (forall a b, callTime2 eqbT a b <= k)
    -> list_eqbTime eqbT A B <= length A * (k+22) + 9.
  Proof.
    intros H'. induction A in B|-*.
    -cbn. lia.
    -destruct B.
    {cbn. intuition. }
    cbn - [callTime2]. setoid_rewrite IHA.
    rewrite H'. ring_simplify. intuition.
  Qed.

  Lemma list_eqbTime_bound_r (eqbT : timeComplexity (X -> X -> bool)) (A B : list X) f:
    (forall (x y:X), callTime2 eqbT x y <= f y) ->
    list_eqbTime eqbT A B <= sumn (map f B) + 9 + length B * 22.
  Proof.
    intros H.
    induction A in B|-*;unfold list_eqbTime;fold list_eqbTime. now Lia.lia.
    destruct B.
    -cbn. Lia.lia.
    -rewrite H,IHA. cbn [length map sumn]. Lia.lia.
  Qed.

  Global Instance eqbList f `{eqbClass (X:=X) f}:
    eqbClass (list_eqb f).
  Proof.
    intros ? ?. eapply list_eqb_spec. all:eauto using eqb_spec.
  Qed.
  Import EqBool.
  Global Instance eqbComp_List `{eqbCompT X (R:=HX)}:
    eqbCompT (list X).
  Proof.
    evar (c:nat). exists c. unfold list_eqb.
    unfold enc;cbn.
    change (eqb0) with (eqb (X:=X)).
    extract. unfold eqb,eqbTime. fold @enc.
    recRel_prettify2. easy.
    [c]:exact (c__eqbComp X + 6).
    all:unfold c. all:cbn iota beta delta [list_enc].
    all:  change ((match HX with
                  | @mk_registered _ enc _ _ => enc
                  end)) with (enc (X:=X)).
    all:cbn [size]. all: nia.
  Qed.

End int.