Require Import STLC_Ref.term STLC_Ref.ty.
Require Import Arith Omega List.

(** 'value' definition.

  Note that we are going to work with a call-by-value reduction, so we
  could remove the variable which don't make sense in an empty context,
  but in practice, it doesn't harm so keeping the usual definition is
  not a problem.
*)
Definition is_value (t: Term) : Prop :=
  match t with
  | # v => True
  | λ[A] , M => True
  | Addr u => True
  | unit => True
  | _ => False
  end.

(* begin hide *)
Lemma is_value_lift: forall T, is_value T -> forall n k, is_value (lift_rec n k T).
Proof.
destruct T as [ v | ? ? | ? ? | | ? | ? | ? | ? ? ]; intros hT n k; simpl;
        try now idtac.
now destruct le_gt_dec.
Qed.

Lemma is_value_subst: forall T, is_value T -> forall n V, is_value V ->
    is_value (subst_rec V T n).
Proof.
destruct T as [ v | ? ? | ? ? | | ? | ? | ? | ? ? ]; intros hT n V hV; simpl;
        try now idtac.
destruct lt_eq_lt_dec as [ [] | ]; try now idtac.
now apply is_value_lift.
Qed.
(* end hide *)

(**
 A memory is a partial map from addresses to untyped terms.
 The typing part will be done by an external map in sr.v.
 All terms in a memory should be regarded as well-typed term _in the empty
 context_.
*)
Definition Mem := list (Addrs * Term).

(* begin hide *)
(* Operators to apply lift/subst to memories *)
Definition lift_mem n k mem :=
    map (fun (aM: Addrs * Term) =>
    let '(a, M) := aM in (a, lift_rec n k M)) mem.

Definition subst_mem V mem n :=
    map (fun (aM: Addrs * Term) =>
    let '(a,  M) := aM in (a, subst_rec V M n))
    mem.
(* end hide *)

(** Check if an address is bound by some generic map (will be used
   for memories and type stores)
*)
(* TODO: utiliser existsb ? *)
Fixpoint InAddr {T: Type} u (l: list (Addrs * T)) :=
    match l with
    | nil => False
    | (a, _) :: tl => if eq_nat_dec a u then True else InAddr u tl
    end.

(* begin hide *)
Lemma InAddr_lift_inv : forall u mem n k,
    InAddr u (lift_mem n k mem) -> InAddr u mem.
Proof.
intros u; induction mem as [ | [a W] tl hi]; intros n k h; simpl in *;
        [ now idtac | ].
destruct Nat.eq_dec as [heq | hne ]; [now idtac| ].
now eapply hi; apply h.
Qed.

Lemma InAddr_subst_inv: forall u mem V n,
    InAddr u (subst_mem V mem n) -> InAddr u mem.
Proof.
intros u; induction mem as [ | [a W] tl hi]; intros n k h; simpl in *;
        [ now idtac | ].
destruct Nat.eq_dec as [heq | hne ]; [now idtac| ].
now eapply hi; apply h.
Qed.
(* end hide *)

(** Bind a new address in a map with some value *)
Definition bindAddr {T : Type} (a: Addrs) (t: T) (l : list (Addrs * T)) :=
    (a, t) :: l.

Lemma Inbind : forall {T : Type} l a u (t: T),
    InAddr a (bindAddr u t l) <-> (a = u \/ InAddr a l).
Proof.
intro t; induction l as [ | [x y] tl hi]; intros a u T; simpl in *.
- split.
  + destruct Nat.eq_dec; intros; [ subst; now left | now right ].
  + intros [ h | h]; [now subst; destruct Nat.eq_dec | now elim h].
- split; intro h.
  + destruct Nat.eq_dec; [now subst; left | ].
    now right.
  + destruct Nat.eq_dec; [now destruct Nat.eq_dec | ].
    destruct h; subst; now destruct Nat.eq_dec.
Qed.

(* begin hide *)
Lemma bindMem_lift : forall a t m n k, lift_mem n k (bindAddr a t m) =
     bindAddr a (lift_rec n k t) (lift_mem n k m).
Proof.
    now intros.
Qed.

Lemma bindMem_subst: forall a t V m n, subst_mem V (bindAddr a t m) n =
    bindAddr a (subst_rec V t n) (subst_mem V m n).
Proof.
    now intros.
Qed.
(* end hide *)

(** Tries to find the associated value to an address in a map.
  If the value is not bound, it will return None.
*)
Fixpoint readAddr {T: Type} (u: Addrs) (l: list (Addrs * T)) :=
    match l with
    | nil => None
    | (a, V) :: tl => if eq_nat_dec a u then Some V else
            readAddr u tl
    end.

(* begin hide *)
Lemma readMem_lift_none: forall u m, readAddr u m = None ->
    forall n k, readAddr u (lift_mem n k m) = None.
Proof.
intro u; induction m as [ | [a V] tl hi]; intros heq n k; simpl in *;
        [ reflexivity | ].
destruct Nat.eq_dec; [ discriminate | now apply hi].
Qed.

Lemma readMem_lift_some : forall u m V, readAddr u m = Some V ->
   forall n k, readAddr u (lift_mem n k m) = Some (lift_rec n k V).
Proof.
intro u; induction m as [ | [a V] tl hi]; intros W heq n k; simpl in *;
        [ discriminate | ].
destruct Nat.eq_dec; [ injection heq; intros ; now subst | ].
now apply hi.
Qed.

Lemma readMem_subst_none: forall u m, readAddr u m = None ->
    forall V n, readAddr u (subst_mem V m n) = None.
intro u; induction m as [ | [a V] tl hi]; intros heq W n; simpl in *;
        [ reflexivity | ].
destruct Nat.eq_dec; [ discriminate | now apply hi].
Qed.

Lemma readMem_subst_some : forall u m V, readAddr u m = Some V ->
   forall W n, readAddr u (subst_mem W m n) = Some (subst_rec W V n).
Proof.
intro u; induction m as [ | [a U] tl hi]; intros V heq W n; simpl in *;
        [ discriminate | ].
destruct Nat.eq_dec; [ injection heq; intros ; now subst | ].
now apply hi.
Qed.
(* end hide *)

Lemma read2In: forall (T: Type) l u (t : T), readAddr u l = Some t ->
    InAddr u l.
Proof.
intro T; induction l as [ | (a, s) tl hi]; intros u t h; simpl in *;
        [ discriminate | ].
now destruct Nat.eq_dec; [ | apply hi with t].
Qed.

Lemma In2read: forall (T: Type) l u, InAddr u l -> exists t:T,
    readAddr u l = Some t.
Proof.
intro T; induction l as [ | (a, s) tl hi]; intros u h; simpl in *;
        [ now idtac | ].
destruct Nat.eq_dec as [ heq | hne].
- subst.
  now exists s.
- now apply hi in h.
Qed.

Lemma readAddr_app {T: Type}: forall D1 u (t: T),
    readAddr u D1 = Some t -> forall D2, readAddr u (D1 ++ D2) = Some t.
Proof.
induction D1 as [ | [a v] tl hi]; intros u t heq D2.
- simpl in heq; now discriminate.
- revert heq; simpl.
  destruct Nat.eq_dec; [ now idtac | intros heq].
  now apply hi.
Qed.

(** Call by Value based on traditional $\beta$ reduction extended
to deal with references:
- (λ[x:A], M)•N → M[[x/N]]
- (mem, ref M) → (mem + (u, M), u) for any u not bound in mem
- (mem, deref u) → (mem, mem(u))
- (mem, u := M) → (mem + (u, M), unit)
- usual contextual extension to make it a congruence

Since we need a memory to interprete the addresses, the reduction relation
associate a term and a memory to a new term and a new memory.
*)
Inductive red : Term -> Mem -> Term -> Mem -> Prop :=
(* Head reduction *)
  | rBeta : forall A M V mem, is_value V ->
          red ((λ[A], M) • V) mem (M [← V]) mem
  | rRef : forall u mem V,  ~ InAddr u mem -> is_value V ->
          red (ref V) mem (Addr u) (bindAddr u V mem)
  | rDeref: forall u mem V, readAddr u mem = Some V ->
         red (deref (Addr u)) mem V mem
  | rStore: forall u V mem, is_value V ->
          red ((Addr u) :=: V) mem unit (bindAddr u V mem)
(* Context rules *)
  | rApp1: forall m1 m2 M M' N , red M m1 M' m2 -> red (M • N) m1 (M' • N) m2
  | rApp2: forall m1 m2 V N  N', is_value V -> red N m1 N' m2 ->
          red  (V • N) m1 ( V  • N') m2
  | rRef1: forall m1 m2 M M', red M m1 M' m2 -> red (ref M) m1 (ref M') m2
  | rDeref1: forall m1 m2 M M', red M m1 M' m2 ->
          red (deref M) m1 (deref M') m2
  | rAssign1 : forall m1 m2 M M' N, red M m1 M' m2 ->
          red (M :=: N) m1 (M' :=: N) m2
  | rAssign2 : forall m1 m2 V N N', is_value V -> red N m1 N' m2 ->
          red (V :=: N) m1 (V :=: N') m2
.

(* begin hide *)
Lemma red_lift: forall m1 m2 M N, red M m1 N m2 -> forall n m,
    red (M ↑ n # m) (lift_mem n m m1) (N ↑ n # m) (lift_mem n m m2).
Proof.
induction 1 as [ ? ? ? ? ? | ? ? ? h ? | ? ? ? ? | ? ? ? ? |
        ? ? ? ? ? h hi | ? ? ? ? ? ? h hi | ? ? ? ? h hi |
        ? ? ? ? h hi | ? ? ? ? ? h hi | ? ? ? ? ? ? h hi ]; intros n m; simpl in *;
                try solve [
            now constructor |
            now constructor; [ apply is_value_lift | apply hi ]].
- change m with (0 + m).
  rewrite (substP1 _ _ m 0 n); simpl.
  constructor.
  now apply is_value_lift.
- simpl.
  econstructor; [ | now apply is_value_lift ].
  intro hh; apply h; now apply InAddr_lift_inv in hh.
- constructor.
  now apply readMem_lift_some.
- constructor.
  now apply is_value_lift.
Qed.

Lemma red_subst : forall m1 m2 M N, red M m1 N m2 ->
    forall n P, is_value P ->
    red (M [ n ← P]) (subst_mem P m1 n) (N [ n ← P]) (subst_mem P m2 n).
Proof.
induction 1 as [ ? ? ? ? ? | ? ? ? h ? | ? ? ? ? | ? ? ? ? |
        ? ? ? ? ? h hi | ? ? ? ? ? ? h hi | ? ? ? ? h hi |
        ? ? ? ? h hi | ? ? ? ? ? h hi | ? ? ? ? ? ? h hi ]; intros n P hP;
             simpl in *; try solve [
               constructor; now apply hi
               | now constructor; [ apply is_value_subst | apply hi]].
- rewrite subst_travers.
  replace (n + 1) with (S n) by intuition.
  econstructor.
  now apply is_value_subst.
- constructor; [ | now apply is_value_subst ].
  intro hh; apply h; now apply InAddr_subst_inv in hh.
- constructor.
  now apply readMem_subst_some.
- constructor.
  now apply is_value_subst.
Qed.

(* Helper function to generate fresh addresses for maps *)
Fixpoint fresh {T: Type} (l : list (Addrs * T)) : Addrs :=
    match l with
    | nil => 0
    | (hd, _) :: tl => S (hd + fresh tl)
    end.

Lemma fresh_is_greater {T: Type} : forall (l: list (Addrs * T)) u,
    InAddr u l -> u < fresh l.
Proof.
induction l as [ | [hd ?] tl hi]; intros u hIn; simpl in *;
        [ now elim hIn | ].
revert hIn.
destruct Nat.eq_dec as [heq | hne]; [ intros _; now subst; omega | intro h].
apply hi in h; now omega.
Qed.

Lemma fresh_is_fresh {T: Type} : forall (l: list (Addrs * T)),
    ~ InAddr (fresh l) l.
Proof.
intros l hin.
apply fresh_is_greater in hin.
now apply lt_irrefl in hin.
Qed.
(* end hide *)


Require Export Utf8.
Require Export Classical.
Require Export FunctionalExtensionality.
Require Export Arith.
Require Export Lia.

(**)
  Definition f_equal2 :
    forall (A B C : Type) (f : A -> B -> C) (x0 x1 : A) (y0 y1 : B),
    x0 = x1 -> y0 = y1 -> f x0 y0 = f x1 y1 :=
  fun (A B C : Type) (f : A → B → C) (x0 x1 : A) (y0 y1 : B) (H : x0 = x1) (H0 : y0 = y1) =>
  match H in (_ = x) return (_ = f x _) with
  | eq_refl =>
    match H0 in (_ = x) return (_ = f _ x) with
    | eq_refl => eq_refl
    end
  end.

  Lemma lt_lt_max_l : forall n m r, n < m -> n < max m r.
  Proof.
  unfold lt.
  intros.
  assert (lml := (Nat.le_max_l m r)).
  apply Nat.le_trans with (m := m).
  auto.
  auto.
  Qed.

  Lemma lt_lt_max_r : forall n m r, n < m -> n < max r m.
  Proof.
  unfold lt.
  intros.
  assert (lml := (Nat.le_max_r r m)).
  apply Nat.le_trans with (m := m).
  auto.
  auto.
  Qed.

  Lemma le_le_max_l : forall n m r, n <= m -> n <= max m r.
  Proof.
  intros.
  assert (lml := (Nat.le_max_l m r)).
  apply Nat.le_trans with (m := m).
  auto.
  auto.
  Qed.

  Lemma le_le_max_r : forall n m r, n <= m -> n <= max r m.
  Proof.
  intros.
  assert (lml := (Nat.le_max_r r m)).
  apply Nat.le_trans with (m := m).
  auto.
  auto.
  Qed.

  Lemma nleb_nle : forall x y, x <=? y = false <-> ~ x <= y.
  Proof.
    intros.
    rewrite <- Bool.not_true_iff_false.
    split. intros.
    contradict H.
    apply Nat.leb_le.
    auto.
    intros.
    contradict H.
    apply Nat.leb_le in H.
    auto.
  Qed.

  Lemma neqb_neq : forall x y, x =? y = false <-> ~ x = y.
  Proof.
    intros.
    split. intros.
    rewrite <- Bool.not_true_iff_false in H.
    contradict H.
    rewrite Nat.eqb_eq. auto.
    intros.
    rewrite <- Bool.not_true_iff_false.
    contradict H.
    rewrite Nat.eqb_eq in H.
    auto.
  Qed.

(**)

Inductive Lambda : Type :=
| var : nat -> Lambda
| lam : Lambda -> Lambda
| app : Lambda -> Lambda -> Lambda.

Notation "' v " := (var v) (at level 5).
Notation "\ l" := (lam l) (at level 25, right associativity).
Notation "x @ y" := (app x y) (at level 20, left associativity).

Notation "\0" := (fun x => ('x)) (at level 0).

Fixpoint sf (n k : nat) l0 :=
  match l0 with
  | 'm      =>
    match (le_lt_dec n m) with
    | left _  => '(k + m) (* n <= m *)
    | right _ => 'm       (* m < n *)
    end
  | \ l     => \ (sf (S n) k l)
  | l1 @ l2 => (sf n k l1) @ (sf n k l2)
  end.

Notation "^" := (sf 0 1).
Notation "^^" := (sf 0 2).
Notation "^^^" := (sf 0 3).
Notation "^^^^" := (sf 0 4).

Lemma sfn0 : forall l n, sf n 0 l = l.
Proof.
  induction l.
  simpl. intros.
  destruct(le_lt_dec n0 n). auto. auto.
  simpl. intros.
  apply f_equal. auto.
  simpl. intros.
  rewrite IHl1.
  rewrite IHl2.
  auto.
Qed.

Lemma sf_sf : forall l n i j, sf n i (sf n j l) = sf n (i + j) l.
Proof.
  induction l.
  - simpl.
    intros.
    destruct(le_lt_dec n0 n).
    simpl.
    destruct(le_lt_dec n0 (j + n)).
    apply f_equal. lia.
    lia.
    simpl.
    destruct(le_lt_dec n0 n).
    lia.
    auto.
  - simpl.
    intros.
    apply f_equal.
    auto.
  - simpl.
    intros.
    rewrite IHl1.
    rewrite IHl2.
    auto.
Qed.

Fixpoint rew (i : nat) (s : nat -> Lambda) (l0 : Lambda) : Lambda :=
  match l0 with
  | 'm      =>
    match le_lt_dec i m with
    | left _  => sf 0 i (s (m - i)) (* i <= m *)
    | right _ => 'm                 (* m < i *)
    end
  | \ l     => \ (rew (S i) s l)
  | l1 @ l2 => (rew i s l1) @ (rew i s l2)
  end.
  Notation "l .[ i # s ]" := (rew i s l) (at level 20, left associativity).

Lemma sf_rew0 : forall l m i s, (sf m i l).[m + i# s] = l.[m# fun x => sf 0 i (s x)].
Proof.
  induction l.
  - simpl.
    intros.
    rewrite sf_sf.
    destruct(le_lt_dec m n).
    simpl.
    destruct(le_lt_dec (m + i) (i + n)).
    assert(i + n - (m + i) = n - m). lia. rewrite H.
    auto.
    lia.
    simpl.
    destruct(le_lt_dec (m + i) n).
    lia.
    auto.
  - simpl.
    intros.
    apply f_equal.
    assert(S (m + i) = (S m) + i). lia. rewrite H.
    auto.
  - simpl.
    intros.
    rewrite IHl1.
    rewrite IHl2.
    auto.
Qed.

Lemma sfm_sf0 : forall l m i, sf m i (sf 0 m l) = sf 0 (m + i) l.
Proof.
  assert(forall l m i j, sf (j + m) i (sf j m l) = sf j (m + i) l).
  - induction l.
    + simpl.
      intros.
      destruct(le_lt_dec j n).
      simpl.
      destruct(le_lt_dec (j + m) (m + n)).
      apply f_equal.
      lia.
      lia.
      simpl.
      destruct(le_lt_dec (j + m) n).
      lia.
      auto.
    + simpl.
      intros.
      apply f_equal.
      assert(S (j + m) = S j + m). lia. rewrite H.
      auto.
    + simpl.
      intros.
      rewrite IHl1.
      rewrite IHl2.
      auto.
  - intros.
    specialize (H l m i 0).
    simpl in H.
    auto.
Qed.

Lemma sf0i_rewi_sf0i : forall l i s,
  (sf 0 i l).[i# s] = sf 0 i (l.[0# s]).
Proof.
  assert(forall l i m s, l.[m# fun x => sf 0 i (s x)] = sf m i (l.[m# s])).
  - induction l.
    + simpl.
      intros.
      rewrite sf_sf.
      destruct(le_lt_dec m n).
      simpl.
      rewrite sfm_sf0.
      auto.
      simpl.
      destruct(le_lt_dec m n).
      lia.
      auto.
    + simpl.
      intros.
      apply f_equal.
      auto.
    + simpl.
      intros.
      rewrite IHl1.
      rewrite IHl2.
      auto.
  - intros.
    assert(S := sf_rew0 l 0 i s).
    simpl in S.
    rewrite S.
    auto.
Qed.

Lemma nested_rew : forall l s0 s1 i,
  l.[i# s0].[i# s1] = l.[i# fun x => s0 x.[0# s1]].
Proof.
  induction l.
  - simpl. intros.
    destruct(le_lt_dec i n).
    apply sf0i_rewi_sf0i.
    simpl.
    destruct(le_lt_dec i n).
    lia.
    auto.
  - simpl.
    intros.
    apply f_equal.
    auto.
  - simpl.
    intros.
    rewrite IHl1.
    rewrite IHl2.
    auto.
Qed.

Lemma sf__rew : forall l i j, sf i j l = l.[i# fun x => '(j + x)].
Proof.
  induction l.
  - simpl.
    intros.
    destruct (le_lt_dec i n).
    apply f_equal.
    lia.
    auto.
  - simpl.
    intros.
    apply f_equal.
    auto.
  - simpl.
    intros.
    rewrite IHl1.
    rewrite IHl2.
    auto.
Qed.

Lemma rew_i0 : forall l i s,
  l.[i # s] = l.[0 # fun x => if (le_lt_dec i x) then sf 0 i (s (x - i)) else 'x].
Proof.
  assert(forall l i s j, l.[j + i # s] = l.[j # fun x => if (le_lt_dec i x) then sf 0 i (s (x - i)) else 'x]).
  - induction l.
    + simpl.
      intros.
      destruct (le_lt_dec (j + i) n).
      destruct (le_lt_dec j n).
      destruct (le_lt_dec i (n - j)).
      rewrite sf_sf.
      assert(n - (j + i) = n - j - i). lia. rewrite H.
      auto.
      lia.
      lia.
      destruct (le_lt_dec j n).
      destruct (le_lt_dec i (n - j)).
      lia.
      simpl.
      apply f_equal. lia.
      auto.
    + simpl.
      intros.
      apply f_equal.
      assert(S (j + i) = (S j) + i). lia. rewrite H.
      auto.
    + simpl.
      intros.
      rewrite IHl1.
      rewrite IHl2.
      auto.
  - intros.
    specialize (H l i s 0).
    simpl in H.
    auto.
Qed.

Lemma nested_rew_g : forall l s0 s1 i j,
  l.[i# s0].[j# s1] =
  l.[0# fun x => (if le_lt_dec i x then sf 0 i (s0 (x - i)) else 'x).[0# fun x0 => if le_lt_dec j x0 then sf 0 j (s1 (x0 - j)) else 'x0]].
Proof.
  intros.
  rewrite (rew_i0 l).
  rewrite (rew_i0 _).
  rewrite (nested_rew l).
  auto.
Qed.

Lemma rew_rew : forall l s0 s1 j, (forall i, s0 i = s1 i) -> l.[j# s0] = l.[j# s1].
Proof.
  intros.
  assert(s0 = s1).
  apply functional_extensionality. auto.
  rewrite H0.
  auto.
Qed.

Definition slide {A : Type} (a : A) (s : nat -> A) : nat -> A := fun x0 =>
  match x0 with
  | 0 => a
  | S m => s m
  end.

Definition embed {A : Type} (a : A) (s : nat -> A) : nat -> A := fun n =>
  match n with
  | 0 => a
  | _ => s n
  end.

Notation "l .# i | x" := (l.[i# slide x \0]) (at level 40, left associativity).
Notation "l .| x" := (l.[0# slide x \0]) (at level 40, left associativity).

Lemma rew_sf : forall l k n, (sf 0 (S n) l) .# n | k = sf 0 n l.
Proof.
  intros.
  rewrite sf__rew.
  rewrite nested_rew_g.
  symmetry.
  rewrite sf__rew.
  apply rew_rew.
  intros.
  destruct (le_lt_dec 0 i).
  simpl.
  destruct (le_lt_dec n (S (n + (i - 0)))).
  assert (match n with | 0 => S (n + i) | S n0 => n + i - n0 end = S i).
  {destruct n. lia. lia. }
  rewrite <- minus_n_O.
  rewrite H.
  simpl.
  auto.
  lia.
  lia.
Qed.

Lemma rew_id : forall l n, l = l.[n# \0].
Proof.
    induction l.
    simpl.
    intros.
    destruct (le_lt_dec n0 n).
    apply f_equal. lia.
    auto.
    intros.
    simpl.
    apply f_equal.
    auto.
    intros.
    simpl.
    rewrite (IHl1 n) at 1.
    rewrite (IHl2 n) at 1.
    auto.
Qed.

Lemma rew_sfll : forall l k n, (sf n 1 l) .# n | k = l.
Proof.
  intros.
  rewrite sf__rew.
  rewrite nested_rew_g.
  symmetry.
  rewrite (rew_id l 0) at 1.
  apply rew_rew.
  simpl.
  intros.
  destruct (le_lt_dec n i).
  simpl.
  rewrite <- minus_n_O.
  assert(n + S (i - n) = S i). lia.
  rewrite H.
  simpl.
  destruct (le_lt_dec n (S i)).
  simpl.
  assert(match n with | 0 => S i | S n0 => i - n0 end = S (i - n)).
  {destruct n. lia. lia. }
  rewrite H0.
  simpl.
  apply f_equal. lia.
  lia.
  Abort.

Fixpoint fv (l0 : Lambda) : nat :=
  match l0 with
  | 'n      => S n
  | \ l     => pred (fv l)
  | l1 @ l2 => max (fv l1) (fv l2)
  end.

Lemma fv_sf : forall l i k, fv l <= i -> sf i k l = l.
Proof.
  induction l.
  - simpl.
    intros.
    destruct (le_lt_dec i n).
    lia.
    auto.
  - simpl.
    intros.
    apply f_equal.
    apply IHl.
    lia.
  - simpl.
    intros.
    rewrite IHl1.
    rewrite IHl2.
    auto.
    lia.
    lia.
Qed.

Lemma fv_rew : forall l i s, fv l <= i -> rew i s l = l.
Proof.
  induction l.
  - simpl.
    intros.
    destruct (le_lt_dec i n).
    lia.
    auto.
  - simpl.
    intros.
    apply f_equal.
    apply IHl.
    lia.
  - simpl.
    intros.
    rewrite IHl1.
    rewrite IHl2.
    auto.
    lia.
    lia.
Qed.

Lemma fv0_sf l : fv l = 0 -> forall n, sf 0 n l = l.
Proof.
  intros.
  apply fv_sf.
  lia.
Qed.

Lemma fv0_rew l : fv l = 0 -> forall i s, rew i s l = l.
Proof.
  intros.
  apply fv_rew.
  lia.
Qed.


Require Import list_examples.

Definition sum_def := FunDef "sum" ["x"]
 {{Decl "s";"s"<-0
  ;SWhile ("x"<>0) {{"s"<-"s"+arr_val "x"; "x"<-arr_next "x"}}
  ;SReturn "s"}}.

Inductive sum_spec : Spec kcfg :=
  sum_claim : forall H l x, heap_fun sum_spec nil
  sum_def [Int x]
    (asP H (rep_list l x))
    (fun r => constraint (r = sum l) :* litP H)
 |loop_claim : forall k H l x, heap_loop sum_spec
  sum_def 0 ("s" s|-> KInt k :* "x" s|-> KInt x)
    (asP H (rep_list l x))
    (fun r => constraint (r = k + sum l) :* litP H).

Lemma sum_proof : sound kstep sum_spec.
Proof. list_solver. Qed.


(*
(precise)administrator@localhost:~$ coqtop
Welcome to Coq 8.3pl4 (April 2012)

Coq < Section Exercise_Fourteen.

Coq < Goal forall u p q o t:Prop, (((u /\ ~~p) -> (q)) /\ (~o -> u) /\ (~p -> o) /\ (~o /\ t)) -> (q).
1 subgoal

  ============================
   forall u p q o t : Prop,
   (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t -> q

Unnamed_thm < intros.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   q

Unnamed_thm < elim H.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   (u /\ ~ ~ p -> q) -> (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t -> q

Unnamed_thm < intro.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  H0 : u /\ ~ ~ p -> q
  ============================
   (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t -> q

Unnamed_thm < intro.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  H0 : u /\ ~ ~ p -> q
  H1 : (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   q

Unnamed_thm < apply H0.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  H0 : u /\ ~ ~ p -> q
  H1 : (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   u /\ ~ ~ p

Unnamed_thm < apply conj.
2 subgoals

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  H0 : u /\ ~ ~ p -> q
  H1 : (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   u

subgoal 2 is:
 ~ ~ p

Unnamed_thm < firstorder.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : (u /\ ~ ~ p -> q) /\ (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  H0 : u /\ ~ ~ p -> q
  H1 : (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   ~ ~ p

Unnamed_thm < destruct H.
1 subgoal

  u : Prop
  p : Prop
  q : Prop
  o : Prop
  t : Prop
  H : u /\ ~ ~ p -> q
  H2 : (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  H0 : u /\ ~ ~ p -> q
  H1 : (~ o -> u) /\ (~ p -> o) /\ ~ o /\ t
  ============================
   ~ ~ p

Unnamed_thm < firstorder.
Proof completed.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
apply H0.
apply conj.
 firstorder  .

 destruct H.
 firstorder  .

Unnamed_thm is defined

Coq <
*)

Section Exercise_Fourteen.
Goal forall u p q o t:Prop, (((u /\ ~~p) -> (q)) /\ (~o -> u) /\ (~p -> o) /\ (~o /\ t)) -> (q).
intros.
elim H.
intro.
intro.
apply H0.
apply conj.
 firstorder.
 destruct H.
 firstorder.
 Qed.


(*
 * Preservation
 *
 * This file contains problems 5 through 9.
 *)

Require Import List.
Require Import ZArith.
Require Import String.
Require Import Frap. (* For tactics *)
Require Import STLC.StructTactics. (* For tactics *)

Require Import STLC.Syntax.
Require Import STLC.Subst.
Require Import STLC.Heap.
Require Import STLC.Semantics.
Require Import STLC.Types.

Open Scope string_scope.

Notation length := List.length.

(*

Our proof of preservation is going to be a little harder than our progress proof;
we're going to need to develop some machinery around environments and
heap types.

*)

(* Equivalence of environments *)
Definition env_equiv (e1 e2: env) : Prop :=
  forall s, e1 s = e2 s.

(* Some lemmas about this equivalence relation. *)

(* reflexivity *)
Lemma env_equiv_refl:
  forall env,
    env_equiv env env.
Proof.
  unfold env_equiv; auto.
Qed.

(* symmetry *)
Lemma env_equiv_sym:
  forall e1 e2,
    env_equiv e1 e2 ->
    env_equiv e2 e1.
Proof.
  unfold env_equiv; auto.
Qed.

(* transitivity *)
Lemma env_equiv_trans:
  forall e1 e2 e3,
    env_equiv e1 e2 ->
    env_equiv e2 e3 ->
    env_equiv e1 e3.
Proof.
  unfold env_equiv; intros.
  congruence.
Qed.

(* extending environments with the same value preserves equivalence *)
Lemma env_equiv_extend:
  forall env1 env2 x t,
    env_equiv env1 env2 ->
    env_equiv (extend env1 x t) (extend env2 x t).
Proof.
  unfold env_equiv, extend; intros.
  break_match; auto.
Qed.

(* if we extend twice with the same variable, it's equivalent to just
extending with the second value (i.e. we "overwrite" values *)
Lemma env_equiv_overwrite:
  forall env x t1 t2,
    env_equiv (extend (extend env x t1) x t2)
              (extend env x t2).
Proof.
  unfold env_equiv, extend; intros.
  break_match; auto.
Qed.

(* If we extend twice with different variables,
   both possible orders result in equivalent envs.
*)
Lemma env_equiv_neq:
  forall env1 env2 x1 t1 x2 t2,
    x1 <> x2 ->
    env_equiv env1 env2 ->
    env_equiv (extend (extend env1 x1 t1) x2 t2)
              (extend (extend env2 x2 t2) x1 t1).
Proof.
  unfold env_equiv, extend; intros.
  break_match; break_match; congruence.
Qed.

(*
 * PROBLEM 5 [5 points, ~25 tactics]: Prove that if a term is typed in an
 * environment, it's typed in equivalent environments.
 *
 * Hint: The lemmas above about env_equiv may be useful.
 *)
Lemma env_equiv_typed:
  forall env1 ht e t,
    typed env1 ht e t ->
    forall env2,
      env_equiv env1 env2 ->
      typed env2 ht e t.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)
(* END PROBLEM 5 *)

(*

Weakening is a structural property of environments: it means that if a
term has some type in an environment, then the term still has that
type if we extend the environment with a new value for any variable
that is free in the term. It's called "weakening" because we can prove
that a term has a type in one environment by removing bindings from
another environment where we know the term is typable.

*)

(*
 * PROBLEM 6 [10 points, ~70 tactics]: Prove weakening for environments.
 *
 * Hint: The lemmas above about env_equiv, including the lemma you just proved,
 * may be useful.
 *)
Lemma weaken:
  forall env ht e t,
    typed env ht e t ->
    forall x t',
      ~ free e x ->
      typed (extend env x t') ht e t.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)
(* END PROBLEM 6 *)

(* Next, we'll define another notion of equivalence: equivalence of
environments with respect to the free variables in a particular
term. If two environments have the same value for every free variable
in a term, then those environments should be interchangeable when
typing that term. *)

Definition free_env_equiv (E: expr) (e1 e2: env) : Prop :=
  forall x,
    free E x ->
    e1 x = e2 x.

(* We'll prove all the same thigs about this equivalence relation *)
Lemma free_env_equiv_refl:
  forall E env,
    free_env_equiv E env env.
Proof.
  unfold free_env_equiv; auto.
Qed.

Lemma free_env_equiv_sym:
  forall E e1 e2,
    free_env_equiv E e1 e2 ->
    free_env_equiv E e2 e1.
Proof.
  unfold free_env_equiv; intros.
  symmetry. apply H; auto.
Qed.

Lemma free_env_equiv_trans:
  forall E e1 e2 e3,
    free_env_equiv E e1 e2 ->
    free_env_equiv E e2 e3 ->
    free_env_equiv E e1 e3.
Proof.
  unfold free_env_equiv; intros.
  apply eq_trans with (y := e2 x); auto.
Qed.

Lemma free_env_equiv_extend:
  forall E env1 env2 x t,
    free_env_equiv E env1 env2 ->
    free_env_equiv E (extend env1 x t) (extend env2 x t).
Proof.
  unfold free_env_equiv, extend; intros.
  break_match; auto.
Qed.

Lemma free_env_equiv_overwrite:
  forall E env x t1 t2,
    free_env_equiv E (extend (extend env x t1) x t2)
                     (extend env x t2).
Proof.
  unfold free_env_equiv, extend; intros.
  break_match; auto.
Qed.

Lemma free_env_equiv_neq:
  forall E env1 env2 x1 t1 x2 t2,
    x1 <> x2 ->
    free_env_equiv E env1 env2 ->
    free_env_equiv E (extend (extend env1 x1 t1) x2 t2)
                     (extend (extend env2 x2 t2) x1 t1).
Proof.
  unfold free_env_equiv, extend; intros.
  break_match; break_match; subst; auto.
  congruence.
Qed.

(* Here's where we prove interchangeability *)
Lemma free_env_equiv_typed:
  forall env1 ht e t,
    typed env1 ht e t ->
    forall env2,
      free_env_equiv e env1 env2 ->
      typed env2 ht e t.
Proof.
  unfold free_env_equiv.
  induction 1; intros.
  - constructor.
  - constructor.
  - constructor. symmetry.
    rewrite <- H. apply H0.
    constructor.
  - econstructor; eauto.
    + apply IHtyped1; intuition.
      apply H1; apply FreeApp_l; auto.
    + apply IHtyped2; intuition.
      apply H1; apply FreeApp_r; auto.
  - econstructor; eauto.
    apply IHtyped; auto.
    unfold extend; intros.
    break_match; auto.
    apply H0. constructor; auto.
  - constructor. auto.
  - constructor. apply IHtyped.
    intros.
    apply H0. constructor. auto.
  - constructor. apply IHtyped.
    intros.
    apply H0. constructor. auto.
  - econstructor.
    + apply IHtyped1. intros.
      apply H1. constructor. auto.
    + apply IHtyped2. intros.
      apply H1. apply FreeAssign_r. auto.
Qed.

(* OK, here's the lemma we needed all that for. The hard part of
proving preservation for the STLC is proving that substitution does
the right thing: if it substitutes something in for a variable in a
body, the body had better have the same type as if we just assumed
that x had that type. *)

(*
 * PROBLEM 7 [10 points, ~50 tactics]: Prove that substitution preserves typing.
 *
 * Hint: The lemmas above about env_equiv and free_env_equiv may be useful,
 * as may be weakening.
 *)
Lemma subst_pres_typed:
  forall e1 e2 x e3,
    Subst e1 e2 x e3 ->
    closed e2 ->
    forall env ht tA tB,
      typed (extend env x tA) ht e1 tB ->
      typed env ht e2 tA ->
      typed env ht e3 tB.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)
(* END PROBLEM 7 *)

(** We're almost there. The last thing we'll need to do is to provide
a way to extend heap types with new values during our preservation
proof. To see why, let's take a look at a version of preservation that
looks a lot like the one for STLC without references: *)

Lemma wrong_preservation:
  forall h h' e e',
    h; e ==> h'; e' ->
    closed e ->
    forall ht t,
      heap_typed ht h ->
      typed E0 ht e t ->
      typed E0 ht e' t.
Abort.

(* The problem is that we're stuck with the same heap type. This is an
issue because when we allocate a new reference, we'll need to extend
our heap type with a type for the new reference cell. So let's
establish what it means for one heap to extend another: *)

Inductive heap_typ_extends: heap_typ -> heap_typ -> Prop :=
| heap_typ_extends_nil :
    forall h, heap_typ_extends h nil
| heap_typ_extends_cons :
    forall h h' x,
      heap_typ_extends h' h ->
      heap_typ_extends (x :: h') (x :: h).

(* We'll need some facts about this definition of heap extension. *)

(* If an address was in our heap type and we extend the heap, we don't
   affect the type for that address.
*)

(*
 * PROBLEM 8 [5 points, ~15 tactics]: Prove extends_lookup.
 *)
Lemma extends_lookup :
  forall h h' a,
    a < length h ->
    heap_typ_extends h' h ->
    lookup_typ h' a = lookup_typ h a.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)
(* END PROBLEM 8 *)

(* Extending a heap increases its length *)
Lemma length_extends :
  forall h h',
    heap_typ_extends h' h ->
    forall a,
      a < length h ->
      a < length h'.
Proof.
  induction 1; intros; simpl in *.
  - omega.
  - destruct a.
    + omega.
    + apply lt_n_S. intuition.
Qed.

(* If we snoc a value onto a heap, that extends the heap. *)
Lemma extends_snoc :
  forall h x,
    heap_typ_extends (snoc h x) h.
Proof.
  intros.
  induction h; simpl in *;
  constructor; auto.
Qed.

(* Heaps extend themselves *)
Lemma extends_refl :
  forall h,
    heap_typ_extends h h.
Proof.
  induction h; constructor; auto.
Qed.

(* We'll need anonther version of weakening:
   types are preserved when extending heaps.
*)
Lemma heap_weakening :
  forall env ht ht' e t,
    typed env ht e t ->
    heap_typ_extends ht' ht ->
    typed env ht' e t.
Proof.
  induction 1; intros; simpl; try solve [econstructor; eauto].
  erewrite <- extends_lookup; eauto.
  constructor.
  eapply length_extends; eauto.
Qed.

(*

OK, we're ready to prove preservation. Note our new theorem
statement: Instead of saying that the term we step to is well-typed
with our starting heap type, we're now saying that there is *some*
heap type which is an extension of our heap type under which the new
term is well-typed. In practice, this new heap type will always either
be the same or the same plus a single type (when a new ref cell is
allocated).

*)

(*
 * PROBLEM 9 [30 points, ~153 tactics]: Prove preservation.
 *
 * Hint: You'll need to be careful about when to provide a witness for the
 * existential, and "eexists" is your friend.
 * Hint: You will need many lemmas from above, as well as from other files.
 * You should familiarize yourself with all of these lemmas.
 *)
Lemma preservation:
  forall h h' e e',
    h; e ==> h'; e' ->
    closed e ->
    forall ht t,
      heap_typed ht h ->
      typed E0 ht e t ->
      exists ht',
        heap_typ_extends ht' ht /\
        typed E0 ht' e' t /\
        heap_typed ht' h'.
Proof.
  (* YOUR PROOF HERE *)
Admitted. (* CHANGE TO QED *)
(* END PROBLEM 9 *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(*i $Id: Multiset.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(* G. Huet 1-9-95 *)

Require Import Permut Setoid.

Set Implicit Arguments.

Section multiset_defs.

  Variable A : Type.
  Variable eqA : A -> A -> Prop.
  Hypothesis eqA_equiv : Equivalence eqA.
  Hypothesis Aeq_dec : forall x y:A, {eqA x y} + {~ eqA x y}.

  Inductive multiset : Type :=
    Bag : (A -> nat) -> multiset.

  Definition EmptyBag := Bag (fun a:A => 0).
  Definition SingletonBag (a:A) :=
    Bag (fun a':A => match Aeq_dec a a' with
                       | left _ => 1
                       | right _ => 0
                     end).

  Definition multiplicity (m:multiset) (a:A) : nat := let (f) := m in f a.

  (** multiset equality *)
  Definition meq (m1 m2:multiset) :=
    forall a:A, multiplicity m1 a = multiplicity m2 a.

  Lemma meq_refl : forall x:multiset, meq x x.
  Proof.
    destruct x; unfold meq; reflexivity.
  Qed.

  Lemma meq_trans : forall x y z:multiset, meq x y -> meq y z -> meq x z.
  Proof.
    unfold meq in |- *.
    destruct x; destruct y; destruct z.
    intros; rewrite H; auto.
  Qed.

  Lemma meq_sym : forall x y:multiset, meq x y -> meq y x.
  Proof.
    unfold meq in |- *.
    destruct x; destruct y; auto.
  Qed.

  (** multiset union *)
  Definition munion (m1 m2:multiset) :=
    Bag (fun a:A => multiplicity m1 a + multiplicity m2 a).

  Lemma munion_empty_left : forall x:multiset, meq x (munion EmptyBag x).
  Proof.
    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
  Qed.

  Lemma munion_empty_right : forall x:multiset, meq x (munion x EmptyBag).
  Proof.
    unfold meq in |- *; unfold munion in |- *; simpl in |- *; auto.
  Qed.

  Require Plus. (* comm. and ass. of plus *)

  Lemma munion_comm : forall x y:multiset, meq (munion x y) (munion y x).
  Proof.
    unfold meq in |- *; unfold multiplicity in |- *; unfold munion in |- *.
    destruct x; destruct y; auto with arith.
  Qed.

  Lemma munion_ass :
    forall x y z:multiset, meq (munion (munion x y) z) (munion x (munion y z)).
  Proof.
    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
    destruct x; destruct y; destruct z; auto with arith.
  Qed.

  Lemma meq_left :
    forall x y z:multiset, meq x y -> meq (munion x z) (munion y z).
  Proof.
    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
    destruct x; destruct y; destruct z.
    intros; elim H; auto with arith.
  Qed.

  Lemma meq_right :
    forall x y z:multiset, meq x y -> meq (munion z x) (munion z y).
  Proof.
    unfold meq in |- *; unfold munion in |- *; unfold multiplicity in |- *.
    destruct x; destruct y; destruct z.
    intros; elim H; auto.
  Qed.

  (** Here we should make multiset an abstract datatype, by hiding [Bag],
      [munion], [multiplicity]; all further properties are proved abstractly *)

  Lemma munion_rotate :
    forall x y z:multiset, meq (munion x (munion y z)) (munion z (munion x y)).
  Proof.
    intros; apply (op_rotate multiset munion meq).
      apply munion_comm.
      apply munion_ass.
      exact meq_trans.
      exact meq_sym.
      trivial.
  Qed.

  Lemma meq_congr :
    forall x y z t:multiset, meq x y -> meq z t -> meq (munion x z) (munion y t).
  Proof.
    intros; apply (cong_congr multiset munion meq); auto using meq_left, meq_right.
      exact meq_trans.
  Qed.

  Lemma munion_perm_left :
    forall x y z:multiset, meq (munion x (munion y z)) (munion y (munion x z)).
  Proof.
    intros; apply (perm_left multiset munion meq); auto using munion_comm, munion_ass, meq_left, meq_right, meq_sym.
      exact meq_trans.
  Qed.

  Lemma multiset_twist1 :
    forall x y z t:multiset,
      meq (munion x (munion (munion y z) t)) (munion (munion y (munion x t)) z).
  Proof.
    intros; apply (twist multiset munion meq); auto using munion_comm, munion_ass, meq_sym, meq_left, meq_right.
    exact meq_trans.
  Qed.

  Lemma multiset_twist2 :
    forall x y z t:multiset,
      meq (munion x (munion (munion y z) t)) (munion (munion y (munion x z)) t).
  Proof.
    intros; apply meq_trans with (munion (munion x (munion y z)) t).
    apply meq_sym; apply munion_ass.
    apply meq_left; apply munion_perm_left.
  Qed.

  (** specific for treesort *)

  Lemma treesort_twist1 :
    forall x y z t u:multiset,
      meq u (munion y z) ->
      meq (munion x (munion u t)) (munion (munion y (munion x t)) z).
  Proof.
    intros; apply meq_trans with (munion x (munion (munion y z) t)).
    apply meq_right; apply meq_left; trivial.
    apply multiset_twist1.
  Qed.

  Lemma treesort_twist2 :
    forall x y z t u:multiset,
      meq u (munion y z) ->
      meq (munion x (munion u t)) (munion (munion y (munion x z)) t).
  Proof.
    intros; apply meq_trans with (munion x (munion (munion y z) t)).
    apply meq_right; apply meq_left; trivial.
    apply multiset_twist2.
  Qed.

  (** SingletonBag *)

  Lemma meq_singleton : forall a a',
    eqA a a' -> meq (SingletonBag a) (SingletonBag a').
  Proof.
    intros; red; simpl; intro a0.
    destruct (Aeq_dec a a0) as [Ha|Ha]; rewrite H in Ha;
      decide (Aeq_dec a' a0) with Ha; reflexivity.
  Qed.

(*i theory of minter to do similarly
Require Min.
(* multiset intersection *)
Definition minter := [m1,m2:multiset]
    (Bag [a:A](min (multiplicity m1 a)(multiplicity m2 a))).
i*)

End multiset_defs.

Unset Implicit Arguments.

Hint Unfold meq multiplicity: v62 datatypes.
Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right
  munion_empty_left: v62 datatypes.
Hint Immediate meq_sym: v62 datatypes.


Require Import List.
Import ListNotations.

Inductive pawn : Type := I | O | U.

Inductive position : Type := A1 | B1 | C1 | A2 | B2 | C2 | A3 | B3 | C3.

Definition row : Type := (pawn * pawn * pawn)%type.

Definition game : Type := (row * row * row)%type.

Definition game_start : game := (
  (U, U, U),
  (U, U, U),
  (U, U, U)
  ).

Definition inv ( p : pawn) : pawn :=
  match p with
  | U => U
  | I => O
  | O => I
  end.

Definition diagI (board : game) : bool :=
  match board with
  | ((I, _, _), (_, I, _), (_, _, I)) => true
  | ((_, _, I), (_, I, _), (I, _, _)) => true
  | _ => false
  end.

Definition diagO (board : game) : bool :=
  match board with
  | ((O, _, _), (_, O, _), (_, _, O)) => true
  | ((_, _, O), (_, O, _), (O, _, _)) => true
  | _ => false
  end.

Definition colI (board : game) : bool :=
  match board with
  | ((I, _, _), (I, _, _), (I, _, _)) => true
  | ((_, I, _), (_, I, _), (_, I, _)) => true
  | ((_, _, I), (_, _, I), (_, _, I)) => true
  | _ => false
  end.

Definition colO (board : game) : bool :=
  match board with
  | ((O, _, _), (O, _, _), (O, _, _)) => true
  | ((_, O, _), (_, O, _), (_, O, _)) => true
  | ((_, _, O), (_, _, O), (_, _, O)) => true
  | _ => false
  end.

Definition rowI (board : game) : bool :=
  match board with
  | ((I, I, I), (_, _, _), (_, _, _)) => true
  | ((_, _, _), (I, I, I), (_, _, _)) => true
  | ((_, _, _), (_, _, _), (I, I, I)) => true
  | _ => false
  end.

Definition rowO (board : game) : bool :=
  match board with
  | ((O, O, O), (_, _, _), (_, _, _)) => true
  | ((_, _, _), (O, O, O), (_, _, _)) => true
  | ((_, _, _), (_, _, _), (O, O, O)) => true
  | _ => false
  end.

Definition get (pos : position) (board : game) : pawn :=
  match pos, board with
  | A1, ((x, _, _), _, _) => x
  | B1, ((_, x, _), _, _) => x
  | C1, ((_, _, x), _, _) => x
  | A2, (_, (x, _, _), _) => x
  | B2, (_, (_, x, _), _) => x
  | C2, (_, (_, _, x), _) => x
  | A3, (_, _, (x, _, _)) => x
  | B3, (_, _, (_, x, _)) => x
  | C3, (_, _, (_, _, x)) => x
  end.

Definition set (pos : position) (board : game) (p : pawn) : game :=
  match pos, board with
  | A1, ((_, x, y), r2, r3) => ((p, x, y), r2, r3)
  | B1, ((x, _, y), r2, r3) => ((x, p, y), r2, r3)
  | C1, ((x, y, _), r2, r3) => ((x, y, p), r2, r3)
  | A2, (r1, (_, x, y), r3) => (r1, (p, x, y), r3)
  | B2, (r1, (x, _, y), r3) => (r1, (x, p, y), r3)
  | C2, (r1, (x, y, _), r3) => (r1, (x, y, p), r3)
  | A3, (r1, r2, (_, x, y)) => (r1, r2, (p, x, y))
  | B3, (r1, r2, (x, _, y)) => (r1, r2, (x, p, y))
  | C3, (r1, r2, (x, y, _)) => (r1, r2, (x, y, p))
  end.

Definition pawn_eq (p q : pawn) : bool :=
  match p, q with
  | I, I => true
  | U, U => true
  | O, O => true
  | _, _ => false
  end.

Lemma pawn_eq_eq (p q : pawn):
  p = q <-> pawn_eq p q = true.
Proof.
  split.
  - induction 1, p; reflexivity.
  - induction p, q; simpl; auto; discriminate.
Qed.

Definition row_eq (r1 r2 : row) : bool :=
  match r1, r2 with
  | (a, b, c), (d, e, f) =>
    pawn_eq a d &&
    pawn_eq b e &&
    pawn_eq c f
  end.

Definition game_eq (g1 g2 : game) : bool :=
  match g1, g2 with
  | (a, b, c), (d, e, f) =>
    row_eq a d &&
    row_eq b e &&
    row_eq c f
  end.

Definition free (pos : position) (board : game) : bool :=
  pawn_eq (get pos board) U.

Definition state : Type := (game * pawn)%type.

Definition winI (board : game) : bool :=
  diagI board || rowI board || colI board.

Definition winO (board : game) : bool :=
  diagO board || rowO board || colO board.

Definition game_done (board : game) : bool :=
  winI board || winO board.

Inductive step : state -> state -> Prop :=
  | play_free : forall pos p board,
    free pos board = true ->
    game_done board = false ->
    step (board, p) (set pos board p, inv p).

Notation "s1 --> s2" := (step s1 s2) (at level 80).

Inductive steps : state -> state -> Prop :=
  | steps_one : forall g1 g2,
    step g1 g2 -> steps g1 g2
  | steps_trans : forall g1 g2 g3,
    step g1 g2 -> steps g2 g3 -> steps g1 g3.

Notation "g1 -->> g2" := (steps g1 g2) (at level 80).

Definition On_going (board : game) :=
  game_done board = false.

Definition Done (board : game) :=
  game_done board = true.

Lemma On_going_start :
  On_going game_start.
Proof. reflexivity. Qed.

Ltac play pos :=
  match goal with
    | [ |- steps _ _ ] => eapply steps_trans; [ play pos | idtac; cbn ]
    | [ |- step _ _ ] => apply (play_free pos _ _); auto
  end.

Ltac win pos :=
  match goal with
    | [ |- steps _ _ ] => apply steps_one; win pos
    | [ |- step _ _ ] => apply (play_free pos); auto
  end.

Example game_win_O :
  exists s, (game_start, O) -->> (s, I) /\ winO s = true.
Proof.
  eexists. split.
  - play A1.
    play A2.
    play B1.
    play B2.
    win C1.
  - reflexivity.
Qed.

Definition step_by (g1 : state) (p : position) (g2 : state) : Prop :=
  step g1 g2 /\ fst g2 = set p (fst g1) (snd g1).

Notation "g1 '-<' p '>->' g2" := (step_by g1 p g2) (at level 80).

Inductive steps_by :  state -> list position -> state -> Prop :=
  | seq_one : forall g1 g2 p,
    g1 -<p>-> g2 ->
    steps_by g1 [p] g2
  | seq_cons : forall g1 g2 g3 pos seq,
    steps_by g2 seq g3 ->
    g1 -<pos>-> g2 ->
    steps_by g1 (pos::seq) g3.

Notation "g1 '-<' p '>->>' g2" := (steps_by g1 p g2) (at level 80).

Lemma steps_by_steps :
  forall seq g1 g2,
  g1 -<seq>->> g2 -> g1 -->> g2.
Proof.
  induction 1 as [ g1 g2 p [H _] | g1 g2 g3 p seq H1 H2 [H3 _]].
  - apply (steps_one _ _ H).
  - apply (steps_trans _ _ _ H3).
    apply H2.
Qed.

Lemma step_step_by :
  forall g1 g2,
  g1 --> g2 -> exists pos, g1 -<pos>-> g2.
Proof.
  intros [g1 p1] [g2 p2] [ pos p board H1 H2 ].
  exists pos; split.
  - apply (play_free _ _ _ H1 H2).
  - reflexivity.
Qed.

Lemma steps_steps_by :
  forall g1 g2,
  g1 -->> g2 -> exists seq, g1 -<seq>->> g2.
Proof.
  induction 1 as [ ? ? [ pos ] | g1 g2 g3 H1 H2 (seq & IH)].
  - exists [pos].
    apply seq_one; split; auto using step.
  - apply step_step_by in H1 as (pos & H).
    exists (pos::seq).
    apply (seq_cons _ _ _ _ _ IH H).
Qed.

Fixpoint interleave {A} (l1 l2 : list A) : list A :=
  match l1, l2 with
  | [], [] => []
  | x::xs, [] => [x]
  | [], y::ys => [y]
  | x::xs, y::ys => x::y::interleave xs ys
  end.

Definition count_row (p : pawn) (r : row) :=
  match r with
  | (a, b, c) =>
      (if pawn_eq p a then 1 else 0)
    + (if pawn_eq p b then 1 else 0)
    + (if pawn_eq p c then 1 else 0)
  end.

Definition count_pawn (p : pawn) (g : game) :=
  match g with
  | (a, b, c) =>
      count_row p a
    + count_row p b
    + count_row p c
  end.

Lemma count_set :
  forall p pos g, 1 + count_pawn p g = count_pawn p (set pos g p).
Proof.
  intros.
  destruct g as [[[[a1 b1] c1] [[a2 b2] c2]] [[a3 b3] c3]].
  induction pos; simpl.
  + assert (pawn_eq p p = true) by (apply pawn_eq_eq; reflexivity).
    rewrite H.
Admitted.

Lemma count_step :
  forall p q g1 g2, (g1, p) --> (g2, q) -> 1 + count_pawn p g1 = count_pawn p g2.
Proof.
Admitted.

Lemma score_bounds :
  forall p q g, (game_start, p) -->> (g, q) ->
    (count_pawn I g = 1 + count_pawn O g) \/
    (count_pawn O g = 1 + count_pawn I g).
Proof.
  intros.
  inversion H.
  - inversion H0; simpl.
    destruct p0; simpl.
Admitted.