From Games Require Import
     Utils.

From Coq Require Import
     List
     Relations.
Import ListNotations.

(**
   We now implement "The far side of the cube" as described by Dan R. Ghica.
   It is stated as being the simplest traditional game semantics in the sense
   that very few restrictions are put on the structure. In this sense, it is
   not a very interesting domain since it is too large for definability to hold
   when taken as a model of a programming language.
   However it is a good starting point upon which enforce additional constraints
   to model various programming constructs.
   This approach is referred to as "Abramsky's Cube".
 *)

Section Arena.

  (**
     [Arena]s are the basic structure upon which games are played.
     It contains:
     - a type [M] of moves that can be taken;
     - a subset of moves [Q] that are interpreted as queries;
     - a subset of moves [O] that are assigned to the opponent;
     - a subset of moves [I] that are initial;
     - a relation of moves stating how taking a move enables new moves to become legal.
   *)

  Class Arena :=
    {
      M:> Type;
      Q: M -> Prop;
      O: M -> Prop;
      I: M -> Prop;
      enable: M -> M -> Prop
    }.

  (* The complement of [Q] are answers [A] *)
  Definition A `{Arena} := fun m => ~ Q m.
  (* The complement of [O] are player moves [P] *)
  Definition P `{Arena} := fun m => ~ O m.

  Infix "⊢" := enable (at level 50).

  (**
     Constraints are then enforced on arenas:
     - Initial moves are exclusively queries by opponent;
     - Only queries can enable new moves;
     - Plays are alternating: a move of a polarity can only enable moves of the other polarity;
     - Initial move cannot be enabled.
   *)
  Record Arena_WF `{Arena} :=
    {
      init_WF: forall m, I m -> Q m /\ O m;
      e1: forall m n, m ⊢ n -> Q m;
      e2: forall m n, m ⊢ n -> (O m <-> P n);
      e3: forall m n, m ⊢ n -> ~ I n
    }.

End Arena.

Infix "⊢" := enable (at level 50).
Notation "⟨ M , Q , O , I , R ⟩" := (Build_Arena M Q O I R).

Inductive void: Type :=.

Section Arena_Constructs.

  (**
     We can then construct combinators over arenas.
   *)

    (* The product is a straightforward join of both arenas.
       Intuitively, both games are played in parallel without any interaction.
     *)
    Definition Prod_Arena (A1 A2: Arena): Arena :=
      ⟨
        @M A1 + @M A2,
        Q +' Q,
        O +' O,
        I +' I,
        enable +'' enable
      ⟩.

    (* The unit arena contains no move. *)
    Definition Unit_Arena: Arena :=
      ⟨
        void,
        FF,
        FF,
        FF,
        FF'
      ⟩.

    (* The arrow arena contains the union of moves.
       However, the polarity of the game to the left of the arrow is reversed.
       The game starts to the right of the arrow.
       Finally, inital moves to the right of the arrow enables the ones to the left.
     *)
    Definition Arrow_Arena (A1 A2: Arena): Arena :=
      {|
        M := @M A1 + @M A2;
        Q := Q +' Q;
        O := P +' O;
        I := inr_ (@I A2);
        enable := (@enable A1 +'' @enable A2) ∪ (inr_ I ->' inl_ I)
      |}.

    Definition Sub_Arena (A : Arena) (P : M -> Prop) :=
      {|
        M := {m : M | P m};
        Q := fun m => match m with exist _ m' _  => Q m' end;
        O := fun m => match m with exist _ m' _ => O m' end;
        I := fun m => match m with exist _ m' _ => I m' end;
        enable := fun m n => match m with exist _ m' _  => match n with exist _ n' _  => enable m' n' end end;

      |}.

End Arena_Constructs.

Notation "'Unit'" := Unit_Arena.
Infix "⊗" := Prod_Arena (at level 29, left associativity).
Infix "↪" := Arrow_Arena (at level 11, right associativity).

(* TODO: Define the isomorphism of Arenas up to which we work.
   Prove that 1 is indeed a unit for the product and arrow.
 *)

Definition bijection {A B : Type} (f : A -> B) :=
  forall x y, x = y <-> f x = f y.

Definition arena_isomorphism {A1 A2 : Arena} (f : @M A1 -> @M A2) : Prop :=
  bijection f /\ forall m n, (@Q A1 m <-> @Q A2 (f m)) /\ (@O A1 m <-> @O A2 (f m)) /\
                 (@I A1 m <-> @I A2 (f m)) /\ (@enable A1 m n <-> @enable A2 (f m) (f n)).

Definition isomorphic (A1 A2 : Arena) : Prop := exists f, @arena_isomorphism A1 A2 f.

Lemma iso_reflexive : forall A, isomorphic A A.
Proof.
  intros. unfold isomorphic, arena_isomorphism. exists (fun x => x).
  split.
  - unfold bijection. intros. split; auto.
  - intros. repeat split; auto.
Qed.

Lemma iso_symmetric : forall A1 A2, isomorphic A1 A2 -> isomorphic A2 A1.
Proof.
  intros. unfold isomorphic, arena_isomorphism in *. destruct H as [f [Hbi Hiso] ].
(** is yielding an inverse function from a bijection constructive?  *)
Admitted.

Lemma iso_transitive : forall A1 A2 A3, isomorphic A1 A2 -> isomorphic A2 A3 -> isomorphic A1 A3.
  intros. unfold isomorphic, arena_isomorphism.
  destruct H as [f12 [Hbi12 Hiso12] ]. destruct H0 as [f23 [Hbi23 Hiso23] ].
  exists (fun x => f23 (f12 x) ). split; intros; repeat split;
  try (intros; specialize (Hiso12 m n); specialize (Hiso23 (f12 m) (f12 n)); tauto).
  - intros. unfold bijection in *. apply Hbi12 in H. apply Hbi23 in H. auto.
  - intros. unfold bijection in *. apply Hbi23 in H. apply Hbi12 in H. auto.
Qed.

Definition isol {A : Arena} (m : void + M) : M :=
  match m with
  | inl v => match v return M with end
  | inr m' => m' end.

Definition isor {A : Arena} (m : M + void) : M :=
  match m with
  | inl m' => m'
  | inr v => match v return M with end
  end.

Lemma unit_left_id_product : forall (A : Arena), exists (f : void + M -> M),
      @arena_isomorphism (Prod_Arena Unit A) A f.
  Proof.
    intro A. exists isol. unfold arena_isomorphism, bijection. split.
    - intros. split; intros; subst; auto. destruct x; destruct y;
       unfold isol in *; simpl in *; try contradiction. subst. auto.
    - intros. repeat split; intros;
      try (destruct m; try contradiction; simpl in *; inv H; try contradiction; auto);
      try (destruct m; try contradiction; simpl in *; constructor; assumption).
      destruct m; destruct n; try contradiction. simpl in *. constructor. assumption.
  Qed.

Lemma unit_right_id_product : forall (A : Arena), exists (f : M + void -> M),
        @arena_isomorphism (Prod_Arena A Unit) A f.
  Proof.
    intros A. exists isor. unfold arena_isomorphism, bijection. split.
    - intros. split; intros; subst; auto. destruct x; destruct y;
       unfold isor in *; simpl in *; try contradiction. subst. auto.
    - intros. repeat split; intros;
      try (destruct m; try contradiction; simpl in *; inv H; try contradiction; auto);
      try (destruct m; try contradiction; simpl in *; constructor; assumption).
      destruct m; destruct n; try contradiction. simpl in *. constructor. assumption.
  Qed.

Lemma unit_left_id_exp : forall (A : Arena), exists (f : void + M -> M),
        @arena_isomorphism (Arrow_Arena Unit A) A f.
  Proof.
    intros A. exists isol. unfold arena_isomorphism, bijection. split.
    - intros. split; intros; subst; auto. destruct x; destruct y;
       unfold isor in *; simpl in *; try contradiction. subst. auto.
    - intros. repeat split; intros;
      try (destruct m; try contradiction; simpl in *; inv H; try contradiction; auto);
      try (destruct m; try contradiction; simpl in *; constructor; assumption).
      + inv H0. simpl. assumption.
      + inv H0. inv H1. contradiction.
      + destruct m; destruct n; try contradiction. simpl in *. repeat constructor. auto.
  Qed.

Definition iso_curry {A B C : Arena} (m : @M A + (@M B + @M C)) : (@M A + @M B) + @M C :=
  match m with
  | inl a => inl (inl a)
  | inr bc =>
    match  bc with
    | inl b => inl (inr b)
    | inr c => inr c
    end
  end.

(** could probably parts of automate this  *)
Lemma currying : forall (A B C : Arena), exists (f : @M A + (@M B + @M C) -> (@M A + @M B) + @M C),
                 @arena_isomorphism  (Arrow_Arena A (Arrow_Arena B C)) (Arrow_Arena (Prod_Arena A B) C) f.
  Proof.
    intros. exists iso_curry. unfold arena_isomorphism, bijection. split.
    - intros. split; intros.
      + subst. auto.
      + destruct x; destruct y; simpl in *; auto; try discriminate.
        * injection H. intros. subst. auto.
        * destruct m0; try discriminate.
        * destruct m; try discriminate.
        * destruct m; destruct m0; try discriminate;
            try (injection H; intros; subst; auto).
   - intros. repeat split; intros.
     + destruct m; simpl in *.
       * inv H. repeat constructor. auto.
       * inv H. inv H1; repeat constructor; auto.
     + destruct m; simpl in *; inv H; try (inv H1).
       * repeat constructor. auto.
       * destruct m; simpl in *; repeat constructor.
         -- injection H0. intros. discriminate.
         -- discriminate.
       * destruct m; simpl in *; repeat constructor.
         -- injection H0. intros. subst. auto.
         -- discriminate.
       * destruct m; try discriminate. injection H0. intros. subst. repeat constructor. auto.
     + destruct m; simpl in *. (** running into issues with the opponent construction ~OA + ~OB vs ~(OA + OB) ?  *)
       * inv H. constructor. unfold P in *. admit.
       * inv H. inv H1.
         -- constructor. unfold P in *. admit.
         -- constructor. auto.
     + destruct m; simpl in *.
       * inv H. constructor. auto. admit.
       * destruct m; simpl in *.
         -- constructor. inv H. constructor.
Admitted.

Section Plays.

  Context {A: Arena}.

  Definition pointer: Type := M * nat.

  Definition pointer_sequence := list pointer.

  (* A play is a pointer_sequence such that the first pointer is an initial
     move, and every subsequent pointer is such that its move is indeed enabled
     by the pointed justifying move *)
  Record play (p: pointer_sequence): Prop :=
    {
      play_justifies: forall p' (m: M) (a: nat),
        snoc p' (m,a) ⊑ p -> p' <> [] ->
        exists q b, Q q /\ p'[[a]] = Some (q,b) /\ q ⊢ m;

      play_init: forall (q: M) (a: nat), [(q,a)] ⊑ p -> I q
    }.

  Definition strategy := pointer_sequence -> Prop.

  (* A strategy is a set of plays that is closed both by prefixed and by legal O-moves *)
  (* Note: traditional presentations only contain the even-lengthed ones contained here *)
  Record strategy_wf (s: strategy): Prop :=
    {
      are_plays: forall p, s p -> play p;
      prefix_closed: forall p p', s p -> p' ⊑ p -> s p';
      Oclosed: forall p m, s p -> play (snoc p m) -> O (fst m) -> s (snoc p m)
    }.

  (* Alternatively, strategies can be defined by a next move function *)
  Definition next_move := pointer_sequence -> (pointer -> Prop).

  Definition next_move_wf (s: next_move): Prop :=
    forall p m a, play p -> s p (m,a) -> play (snoc p (m,a)).

  Inductive strategy_from_next_move (next: next_move): strategy :=
  | Empty_play: strategy_from_next_move next []
  | P_move: forall p m a,
      strategy_from_next_move next p ->
      next p (m,a) ->
      strategy_from_next_move next (snoc p (m,a))
  | O_move: forall p m a,
      O m ->
      strategy_from_next_move next p ->
      play (snoc p (m,a)) ->
      strategy_from_next_move next (snoc p (m,a)).
  Hint Constructors strategy_from_next_move.

  Lemma nil_is_play: play [].
  Proof.
    split; intros.
    - inv H; exfalso; eauto.
    - inv H; exfalso; eauto.
  Qed.
  Hint Resolve nil_is_play.

  Lemma strategy_from_next_move_wf:
    forall next, next_move_wf next ->
            strategy_wf (strategy_from_next_move next).
  Proof.
    intros next nextWF; split.
    - induction p as [| [m a] p IH] using rev_ind; auto.
      intros ?.
      inv H.
      + exfalso; eauto.
      + apply nextWF; auto.
        apply snoc_inj in H0; destruct H0; subst; auto.
      + apply snoc_inj in H0; destruct H0; subst; auto.
    - intros p p' strat; revert p'; induction strat; intros p' prefix.
      + inv prefix; auto.
      + apply prefix_snoc in prefix; destruct prefix as [-> | ?]; auto.
      + apply prefix_snoc in prefix; destruct prefix as [-> | ?]; auto.
    - intros p m strat; revert m; induction strat; intros [] PLAY HO; auto.
  Qed.

  (* Least strategy spanned by a set of plays.
     TODO: think about this for a more interesting definition.
   *)
  Record least_strat (generators: pointer_sequence -> Prop) (s: strategy): Prop :=
    {
      generators_plays: forall p, generators p -> play p;
      s_strategy: strategy_wf s;
      s_least_strategy: forall s', strategy_wf s' -> generators ⊆ s' -> s ⊆ s'
    }.

  Fixpoint deletion (p: pointer_sequence): pointer_sequence :=
    match view p with
    | Nil => []
    | Snoc x p => []
    end.

  Definition decr_above_or_eq (n : nat) (f : nat -> nat) :=
    fun m => if Nat.ltb n m then f m - 1 else f m.

  Fixpoint delete_fun (p : pointer_sequence) (X : M -> bool) : pointer_sequence * (nat -> nat) :=
    match  p with
    | [] => ([], fun x => x)
    | x :: p => let (m,n) := x in
                  let (p',f) := delete_fun p X in
                  if X m
                  then (p', decr_above_or_eq (length p + 1) f )
                  else (x :: p',f) end.
(**not sure this preserves play requirements*)
  Inductive delete_rel : pointer_sequence -> pointer_sequence -> (M -> Prop) -> (nat -> nat) -> Prop :=
    | del_nil (P : M -> Prop) : delete_rel nil nil P (fun x => x)
    | del_snoc_in (p p' : pointer_sequence) (P : M -> Prop) (m : M) (Hm : P m) (n : nat) (f : nat -> nat)
                  (Hpp' :delete_rel p' p P f) : delete_rel p' (snoc p (m,n)) P (decr_above_or_eq (length p') f)
    | del_snoc_out (p p' : pointer_sequence) (P : M -> Prop) (m : M) (Hm : ~ P m) (n : nat) (f : nat -> nat)
                   (Hpp' : delete_rel p' p P f) : delete_rel (snoc p' (m,n)) (snoc p (m,n)) P f
.

  Definition name_set := nat -> bool.
  Definition empty : name_set := fun x => false.
  Definition add_elem x (s : name_set) := fun y => if Nat.eqb x y then true else s y.
  Definition contains (s : name_set) x := s x.
  Definition union (s t : name_set) := fun x => orb (s x)  (t x).

  Fixpoint hered_just_fun (p : pointer_sequence) (X : M -> bool) : pointer_sequence * name_set :=
    match p with
    | [] => ([], empty)
    | x :: p => let (m,n) := x in
                let (p', s) := hered_just_fun p X in
                if X m
                then (x :: p', add_elem (length p) s)
                else (p',s)
    end.

  Inductive hered_just_rel : pointer_sequence -> pointer_sequence -> (M -> Prop) -> (nat -> Prop) -> Prop :=
    | hered_nil (P : M -> Prop) : hered_just_rel [] [] P (fun x => False)
    | hered_snoc_in (p p' : pointer_sequence) (P : M -> Prop) (m : M) (Hm : P m) (n : nat) (S : nat -> Prop)
                    (Hpp' : hered_just_rel p' p P S) : hered_just_rel (snoc p' (m,n)) (snoc p (m,n)) P
                                                                      (fun x => S x \/ x = length p)
    | hered_snoc_out (p p' : pointer_sequence) (P : M -> Prop) (m : M) (Hm : ~ P m) (n : nat) (S : nat -> Prop)
                    (Hpp' : hered_just_rel p' p P S) : hered_just_rel p' (snoc p (m,n)) P S
  .

End Plays.

Lemma Forall_tail : forall (A : Type) (P : A -> Prop) (a : A) (l : list A), Forall P (a :: l) -> (P a /\ Forall P l).
Proof.
  intros. inv H; auto.
Qed.

Definition list_subset_project (A : Type) (P : A -> Prop) (l : list A) (Hl : Forall P l) : list {a : A | P a}.
  induction l.
  - apply ([]).
  - apply Forall_tail in Hl as [Ha Ht]. remember (exist P a Ha). specialize (IHl Ht).
    apply (s :: IHl).
Defined.

Lemma preserve_elem : forall (A : Type) (P : A-> Prop) (l : list A) (Hl : Forall P l),
    map (fun x => match x with exist _ a _ => a end) (list_subset_project A P l Hl) = l.
Proof.
  intros. induction l; auto.
  simpl.  destruct ( Forall_tail A0 P0 a l Hl). simpl. rewrite IHl. auto.
Qed.


Require Import floyd.proofauto. (* Import the Verifiable C system *)
Require Import progs.sumarray. (* Import the AST of this C program *)
(* The next line is "boilerplate", always required after importing an AST. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(* Some definitions relating to the functional spec of this particular program.  *)
Definition sum_Z : list Z -> Z := fold_right Z.add 0.

Lemma sum_Z_app:
  forall a b, sum_Z (a++b) =  sum_Z a + sum_Z b.
Proof.
  intros. induction a; simpl; omega.
Qed.

(* Beginning of the API spec for the sumarray.c program *)
Definition sumarray_spec :=
 DECLARE _sumarray
  WITH a: val, sh : share, contents : list Z, size: Z
  PRE [ _a OF (tptr tint), _n OF tint ]
          PROP  (readable_share sh; 0 <= size <= Int.max_signed;
                     Forall (fun x => Int.min_signed <= x <= Int.max_signed) contents)
          LOCAL (temp _a a; temp _n (Vint (Int.repr size)))
          SEP   (data_at sh (tarray tint size) (map Vint (map Int.repr contents)) a)
  POST [ tint ]
        PROP () LOCAL(temp ret_temp  (Vint (Int.repr (sum_Z contents))))
           SEP (data_at sh (tarray tint size) (map Vint (map Int.repr contents)) a).

(* Note: It would also be reasonable to let [contents] have type [list int].
  Then the [Forall] would not be needed in the PROP part of PRE.
*)

(* The spec of "int main(void){}" always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
        ltac:(with_library prog [sumarray_spec; main_spec]).

(* Loop invariant, for use in body_sumarray.  *)
Definition sumarray_Inv a0 sh contents size :=
 EX i: Z,
   PROP  (0 <= i <= size)
   LOCAL (temp _a a0;
          temp _i (Vint (Int.repr i));
          temp _n (Vint (Int.repr size));
          temp _s (Vint (Int.repr (sum_Z (sublist 0 i contents)))))
   SEP   (data_at sh (tarray tint size) (map Vint (map Int.repr contents)) a0).

(** Proof that f_sumarray, the body of the sumarray() function,
 ** satisfies sumarray_spec, in the global context (Vprog,Gprog).
 **)
Lemma body_sumarray: semax_body Vprog Gprog f_sumarray sumarray_spec.
Proof.
start_function.  (* Always do this at the beginning of a semax_body proof *)
(* The next two lines do forward symbolic execution through
   the first two executable statements of the function body *)
forward.  (* i = 0; *)
forward.  (* s = 0; *)
(* To do symbolic execution through a [while] loop, we must
 * provide a loop invariant, so we use [forward_while] with
 * the invariant as an argument .*)
forward_while (sumarray_Inv a sh contents size).
(* forward_while leaves four subgoals; here we label them
   with the * bullet. *)
* (* Prove that current precondition implies loop invariant *)
Exists 0.   (* Instantiate the existential on the right-side of |--   *)
entailer!.  (* Simplify this entailment as much as possible; in this
      case, it solves entirely; in other cases, entailer! leaves subgoals *)
* (* Prove that loop invariant implies typechecking condition *)
entailer!.  (* Typechecking conditions usually solve quite easily *)
* (* Prove postcondition of loop body implies loop invariant *)
(* In order to get to the postcondition of the loop body, of course,
   we must forward-symbolic-execute through the loop body;
   so we start that here. *)
(* "forward" fails and tells us to first make (0 <= i < Zlength contents)
   provable by auto, so we assert the following: *)
assert_PROP (Zlength contents = size). {
  entailer!. do 2 rewrite Zlength_map. reflexivity.
}

forward. (* x = a[i] *)
forward. (* s += x; *)
forward. (* i++; *)
 (* Now we have reached the end of the loop body, and it's
   time to prove that the _current precondition_  (which is the
   postcondition of the loop body) entails the loop invariant. *)
 Exists (i+1).
 entailer!.
 clear - H HRE H1.
 f_equal. f_equal.
 rewrite (sublist_split 0 i (i+1)) by omega.
 rewrite sum_Z_app. rewrite (sublist_one i) with (d:=0) by omega.
 simpl. rewrite Z.add_0_r. reflexivity.
* (* After the loop *)
forward.  (* return s; *)
 (* Here we prove that the postcondition of the function body
    entails the postcondition demanded by the function specification. *)
entailer!.
autorewrite with sublist in *.
autorewrite with sublist.
reflexivity.
Qed.

(* Contents of the extern global initialized array "_four" *)
Definition four_contents := [1; 2; 3; 4].

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.
forward_call (*  s = sumarray(four,4); *)
  (four,Ews,four_contents,4).
 split3; auto. computable.
 repeat constructor; computable.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_sumarray.
semax_func_cons body_main.
Qed.


(* This module defines trees over functors represented by containers
(i.e. fixpoints of functors). *)

Require Export Vector.
Require Export Container.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Basics.
Require Export Coq.Program.Equality.
Require Export Algebra.

Set Implicit Arguments.

Section Tree.

Set Implicit Arguments.

Variable C : Cont.

Inductive Tree : Type :=
| In : Ext C Tree -> Tree.

(* Custom induction principle. *)

Fixpoint Tree_ind' (P : Tree -> Prop)
         (step : forall  (args : Ext C Tree),
                   cforall P args -> P (In args))
         g : P g :=
  match g with
    | In args => step args (fun p => Tree_ind' step (elems args p))
  end.

End Tree.

(* This defines the fold corresponding to the given algebra. *)

Fixpoint fold {C R} (alg : Alg C R) (g : Tree C) : R :=
  match g with
    | In args => alg (cmap (fold alg) args)
  end.

Ltac tree_ind g := induction g using Tree_ind';simpl; auto.

(* Fold fusion theorem. *)

Theorem fold_fusion
        {C R1 R2}
        (alg1 : Alg C R1)
        (alg2 : Alg C R2)
        (g : Tree C) (f : R1 -> R2) :
  (forall x, f (alg1 x) = alg2 (cmap f x)) ->
  f (fold alg1 g) = fold alg2 g.
Proof.

  intros Hom. tree_ind g.

  rewrite Hom. rewrite cmap_cmap. f_equal.
  apply cforall_rewrite. unfold compose. unfold cforall in *. auto.
Qed.


(**
# 第9回 タクティックの定義と利用/停止性証明 (2014/06/08)

http://qnighy.github.io/coqex2014/

## 課題42 (種別:A / 締め切り : 2014/06/15)

自然数におけるlog関数(底は2)を以下のテンプレートに従って定義せよ。
テンプレートを改変しているので、このままで応募してはいけない。
*)

Require Import Arith.
Require Import Omega.
Require Import Recdef.

(* 定理としてどこかにあると思うのだが。 *)
(* http://www.cse.chalmers.se/research/group/logic/TypesSS05/resources/coq/CoqArt/gen-rec/SRC/chap15.v *)
Theorem lt_Acc : forall n:nat, Acc lt n.
Proof.
 induction n.
 split; intros p H; inversion H.
 split.
 intros y H0.
 case (le_lt_or_eq _ _ H0).
 intro; apply Acc_inv with n; auto with arith.
 intro e; injection e; intro e1; rewrite e1; assumption.
Qed.

Function log(n:nat) {wf lt n} :=
  if le_lt_dec n 1 then
    0
  else
    S (log (Div2.div2 n)).
Proof.
  intros.
  Search (Div2.div2 _ < _).
  Check Div2.lt_div2.
  apply Div2.lt_div2.
  omega.
  Search well_founded.
  unfold well_founded.
  apply lt_Acc.
Qed.

(*
ヒント

Fixpointでは構造に基づく帰納法しか書けませんでした。Coqが自動的に停止性を判断できないような
関数の定義をするために、Functionコマンドが用意されています。停止性はwf (パラメーターのうち
の1つが整礎的な関係に従って降下していくことを示す) または measure (パラメーターのうちの1つ
に自然数の重みを定める関数があり、再帰呼び出しはこの重みが減る方向に進むということを示す)
の2つの方法があります。

*)

(* END *)


Load Common.

Require Import FormulaFacts.
Require Import Derivations.
Require Import Encoding.
Require Import UserTactics.
Require Import Psatz. (*lia : linear integer arithmetic*)
Require Import Diophantine.

Require Import ListFacts.

Lemma derive_quantified_arrow : forall n s t, derivation [triangle] (quantify_formula n t) -> derivation [triangle] (quantify_formula n (arr s t)).
Proof.
elim.
intros.
apply intro_arr.
apply : weakening; [eassumption | list_inclusion].
intros.
simpl.
apply intro_quant.

move => a.
gimme derivation.
simpl.
move /inv_quant/(_ a).
rewrite ? instantiate_quantification.
(have : (n + 0) = n by omega) => ->.
move => HD.
simpl.
apply : H => //.
Qed.

Lemma eliminate_I : forall (ds : list diophantine) (s : formula), In s (ΓI ds) -> derivation [triangle] s.
Proof.
intros.
filter_context_derivation.
unfold s_x_d.
apply : derive_quantified_arrow.
move : (diophantine_variable_bound ds).
elim ds.
(*base case ds = []*)
elim.
derivation_rule.
simpl; intros.
apply : intro_quant.
intros.
rewrite instantiate_quantification.
assumption.

(*inductive case*)
case; (intros; simpl; do ? (apply : derive_quantified_arrow); auto).
Qed.

(*replace ΓS by a_s in assumption*)
Ltac generalize_ΓS :=
  match goal with
  | [ H' : ∀ s : formula, In s ?ΓS → encodes_sum s, H : derivation ?Γ ?s |- _] =>
    match Γ with
    | context G [ΓS] => let G' := context G [[a_s]] in
      eapply (context_generalization (Δ := G')) in H;
      last (
        let H_in := fresh in intros ? H_in; filter_context_derivation;
        move /H' : H_in => [? [? [? [? _]]]]; subst; derivation_rule)
    end
  end.

(*replace ΓP by a_p in assumption*)
Ltac generalize_ΓP :=
  match goal with
  | [ H' : ∀ s : formula, In s ?ΓP → encodes_prod s, H : derivation ?Γ ?s |- _] =>
    match Γ with
    | context G [ΓP] => let G' := context G [[a_p]] in
      eapply (context_generalization (Δ := G')) in H;
      last (
        let H_in := fresh in intros ? H_in; filter_context_derivation;
        move /H' : H_in => [? [? [? [? _]]]]; subst; derivation_rule)
    end
  end.

(*replace ΓU by a_u in assumption*)
Ltac generalize_ΓU :=
  match goal with
  | [ H' : ∀ s : formula, In s ?ΓU → represents_nat s, H : derivation ?Γ ?s |- _] =>
    match Γ with
    | context G [ΓU] => let G' := context G [[a_u]] in
      eapply (context_generalization (Δ := G')) in H;
      last (
        let H_in := fresh in intros ? H_in; filter_context_derivation;
        move /H' : H_in => [? [? ?]]; subst; derivation_rule)
    end
  end.

(*replace ΓI by triangle in assumption*)
Ltac generalize_ΓI :=
  match goal with
  | [ H : derivation ?Γ _ |- _] =>
    match Γ with
    | context G [ΓI] => let G' := context G [[triangle]] in
      eapply (context_generalization (Δ := G')) in H;
      last (
        intros ? ?; filter_context_derivation)
    end
  end.

Lemma get_interpretation : forall (s : formula) (ΓU : list formula),
  (forall {s : formula}, In s ΓU -> represents_nat s) ->
  derivation (ΓU ++ [triangle; a_s; a_p]) (U s) ->
  exists (m : nat), interpretation s m /\ m > 0.
Proof.
move => s ΓU HΓU HD.
decompose_derivation.
filter_context_chain => ?.
move : (HΓU _ ltac:(eassumption)) => [m [? ?]]; subst.
exists m; split; last done.
decompose_chain.
decompose_Forall.
do 2 generalize_ΓU.
decompose_derivation.
do 2 filter_context_chain.
decompose_Forall.
gimme derivation; gimme derivation => HD2 HD1.
constructor.
(*show +s -> +m*)
do 2 (apply intro_arr).
eapply (context_generalization (Δ := (represent_nat m :: to_dagger s :: calC))) in HD1.
2 : { intros; filter_context_derivation. }
have : derivation (represent_nat m :: to_dagger s :: calC) (to_dagger s) by derivation_rule.
intros; by derivation_rule.
(*show +m -> +s*)
eapply (context_generalization (Δ := ((to_dagger (represent_nat m)) :: calC))) in HD2.
2 : { intros; filter_context_derivation. }
derivation_rule.
Qed.

Lemma derivation_atom_eq : forall (a b : label), ~(In (Formula.atom a) (dagger :: calC)) -> ~(In (Formula.atom b) (dagger :: calC)) ->
  derivation calC (Formula.arr (to_dagger (Formula.atom a)) (to_dagger (Formula.atom b))) -> a = b.
Proof.
intros.
decompose_derivation.
filter_context_chain. exfalso; intuition.
decompose_Forall.
decompose_derivation.
filter_context_chain; (firstorder done).
Qed.

Lemma derivation_represent_nat_eq : forall (m1 m2 : nat),
  derivation calC (Formula.arr (to_dagger (represent_nat m1)) (to_dagger (represent_nat m2))) -> m1 = m2.
Proof.
intros.
suff : get_label (represent_nat m1) = get_label (represent_nat m2) by case.
apply: derivation_atom_eq => //; firstorder done.
Qed.

Lemma chain_intro_sum (params : list formula) : chain s_x_s (get_label triangle) params ->
  exists (s1 s2 s3 s4 s5 : formula),
    (params = [U s1; U s2; U s3; U s4; U s5; S s1 s2 s3; S s2 one s4; S s3 one s5; Formula.arr (S s1 s4 s5) triangle]).
Proof.
case; intros; first do ? decompose_contains.
gimme chain; do ? decompose_contains.
move => ?; decompose_chain.
by do 5 eexists.
Qed.

Lemma chain_intro_prod (params : list formula) : chain s_x_p (get_label triangle) params ->
  exists (s1 s2 s3 s4 s5 : formula),
    (params = [U s1; U s2; U s3; U s4; U s5; P s1 s2 s3; S s2 one s4; S s3 s1 s5; Formula.arr (P s1 s4 s5) triangle]).
Proof.
case; intros; first do ? decompose_contains.
gimme chain; do ? decompose_contains.
move => ?; decompose_chain.
by do 5 eexists.
Qed.

Lemma chain_intro_element (params : list formula): chain s_x_u (get_label triangle) params ->
  exists (s : formula), lc 0 s /\
    (params = [U s; quant ( arr (U (var 0)) (arr (S s one (var 0)) (arr (P (var 0) one (var 0)) triangle)))]).
Proof.
case; intros; first do ? decompose_contains.
gimme chain; do ? decompose_contains.
move => ?; decompose_chain.
eexists. by split; [eassumption | ].
Qed.

Lemma derivation_arr_trans : forall (Γ : list formula) (s t u : formula),
  derivation Γ (arr s t) -> derivation Γ (arr t u) -> derivation Γ (arr s u).
Proof.
intros * => Hst Htu.
apply intro_arr.
apply inv_arr in Hst.
apply (weakening (Δ := (s :: Γ))) in Htu; last list_inclusion.
apply: elim_arr; eassumption.
Qed.

Lemma interpretation_soundness : forall (s : formula) (m1 m2 : nat), interpretation s m1 -> interpretation s m2 -> m1 = m2.
Proof.
move => s m1 m2 [_ Hm1_2] [Hm2_1 _].
move : (derivation_arr_trans Hm1_2 Hm2_1).
by move /derivation_represent_nat_eq.
Qed.

Lemma interpretation_soundness_arr : forall (s1 s2 : formula) (m1 m2 : nat),
  derivation calC (arr (to_dagger s1) (to_dagger s2)) -> interpretation s1 m1 -> interpretation s2 m2 -> m1 = m2.
Proof.
intros * => s1s2 [_ m1s1] [s2m2 _].
move : (derivation_arr_trans m1s1 s1s2) => m1s2.
move : (derivation_arr_trans m1s2 s2m2).
by move /derivation_represent_nat_eq.
Qed.

Lemma assert_sum : forall (s1 s2 s3 : formula) (m1 m2 m3 : nat) (ΓU ΓS ΓP : list formula),
  (forall {s : formula}, In s ΓS -> encodes_sum s) ->
  interpretation s1 m1 -> interpretation s2 m2 -> interpretation s3 m3 ->
  derivation (ΓS ++ [triangle; a_u; a_p]) (S s1 s2 s3) ->
  m1 + m2 = m3.
Proof.
intros until 3 => Hs1 Hs2 Hs3 HD.
decompose_derivation.
filter_context_chain => Hc.
match goal with [ _ : In ?s ΓS |- _] => have : encodes_sum s by auto end.
move => [s1' [s2' [s3' [?]]]] [m1' [m2' [m3' [Hs1' [Hs2' [Hs3' ?]]]]]].
subst. decompose_chain.
decompose_Forall.
do ? (generalize_ΓS).

decompose_derivation.
do ? (filter_context_chain).
decompose_Forall.

do 3 (gimme derivation).
do 3 (move /intro_arr => ?).
suff : m1' = m1. suff : m2' = m2. suff : (m1' + m2') = m3.
intros. by subst.

all: apply: (interpretation_soundness_arr); try eassumption.
all: apply: (context_generalization); [eassumption | by intros; filter_context_derivation].
Qed.

Lemma assert_prod : forall (s1 s2 s3 : formula) (m1 m2 m3 : nat) (ΓU ΓS ΓP : list formula),
  (forall {s : formula}, In s ΓP -> encodes_prod s) ->
  interpretation s1 m1 -> interpretation s2 m2 -> interpretation s3 m3 ->
  derivation (ΓP ++ [triangle; a_u; a_s]) (P s1 s2 s3) ->
  m1 * m2 = m3.
Proof.
intros until 3 => Hs1 Hs2 Hs3 HD.
decompose_derivation.
filter_context_chain => Hc.
match goal with [ _ : In ?s ΓP |- _] => have : encodes_prod s by auto end.
move => [s1' [s2' [s3' [?]]]] [m1' [m2' [m3' [Hs1' [Hs2' [Hs3' ?]]]]]].
subst. decompose_chain.
decompose_Forall.
do ? (generalize_ΓP).

decompose_derivation.
do ? (filter_context_chain).
decompose_Forall.

do 3 (gimme derivation).
do 3 (move /intro_arr => ?).
suff : m1' = m1. suff : m2' = m2. suff : (m1' * m2') = m3.
intros. by subst.

all: apply: (interpretation_soundness_arr); try eassumption.
all: apply: (context_generalization); [eassumption | by intros; filter_context_derivation].
Qed.

Lemma generalize_ISP : forall (n : nat) (ΓU ΓS ΓP : list formula),
  (forall {s : formula}, In s ΓS -> encodes_sum s) ->
  (forall {s : formula}, In s ΓP -> encodes_prod s) ->
  forall (ds : list diophantine) (s : formula), normal_derivation n (ΓI ds ++ ΓU ++ ΓS ++ ΓP) (U s) -> derivation (ΓU ++ [triangle; a_s; a_p]) (U s).
Proof.
intros.
gimme normal_derivation. move /normal_derivation_soundness => HD.
apply : (context_generalization HD).
intros.
filter_context_derivation.
apply : (weakening (Γ := [triangle])); last by list_inclusion.
apply : (eliminate_I (ds := ds)); list_inclusion.
match goal with | [ _ : In ?s ΓS |- _] => have : encodes_sum s by auto end.
move => [? [? [? [? ?]]]]; subst; derivation_rule.
match goal with | [ _ : In ?s ΓP |- _] => have : encodes_prod s by auto end.
move => [? [? [? [? ?]]]]; subst; derivation_rule.
Qed.

Lemma generalize_IUP : forall (n : nat) (ΓU ΓS ΓP : list formula),
  (forall {s : formula}, In s ΓU -> represents_nat s) ->
  (forall {s : formula}, In s ΓP -> encodes_prod s) ->
  forall (ds : list diophantine) (s1 s2 s3 : formula), normal_derivation n (ΓI ds ++ ΓU ++ ΓS ++ ΓP) (S s1 s2 s3) ->
  derivation (ΓS ++ [triangle; a_u; a_p]) (S s1 s2 s3).
Proof.
intros.
gimme normal_derivation. move /normal_derivation_soundness => HD.
apply : (context_generalization HD).
intros.
filter_context_derivation.
apply : (weakening (Γ := [triangle])); last by list_inclusion.
apply : (eliminate_I (ds := ds)); list_inclusion.
match goal with | [ _ : In ?s ΓU |- _] => have : represents_nat s by auto end.
move => [? [? ?]]; subst; derivation_rule.
match goal with | [ _ : In ?s ΓP |- _] => have : encodes_prod s by auto end.
move => [? [? [? [? ?]]]]; subst; derivation_rule.
Qed.

Lemma generalize_IUS : forall (n : nat) (ΓU ΓS ΓP : list formula),
  (forall {s : formula}, In s ΓU -> represents_nat s) ->
  (forall {s : formula}, In s ΓS -> encodes_sum s) ->
  forall (ds : list diophantine) (s1 s2 s3 : formula), normal_derivation n (ΓI ds ++ ΓU ++ ΓS ++ ΓP) (P s1 s2 s3) ->
  derivation (ΓP ++ [triangle; a_u; a_s]) (P s1 s2 s3).
Proof.
intros.
gimme normal_derivation. move /normal_derivation_soundness => HD.
apply : (context_generalization HD).
intros.
filter_context_derivation.
apply : (weakening (Γ := [triangle])); last by list_inclusion.
apply : (eliminate_I (ds := ds)); list_inclusion.
match goal with | [ _ : In ?s ΓU |- _] => have : represents_nat s by auto end.
move => [? [? ?]]; subst; derivation_rule.
match goal with | [ _ : In ?s ΓS |- _] => have : encodes_sum s by auto end.
move => [? [? [? [? ?]]]]; subst; derivation_rule.
Qed.

Ltac decompose_USP :=
  do [
    gimme shape (normal_derivation _ _ (U _));
    move /(generalize_ISP HS HP)/(get_interpretation HU)=> [? [? ?]] |
    gimme shape (normal_derivation _ _ (S _ _ _));
    let H := fresh in
      (move/(generalize_IUP HU HP) => H; (eapply assert_sum in H => //); try eassumption) |
    gimme shape (normal_derivation _ _ (P _ _ _));
    let H := fresh in
      (move/(generalize_IUS HU HS) => H; (eapply assert_prod in H => //); try eassumption) ].

Lemma exists_succ : forall (P : nat -> Prop),
  (exists (m : nat), P m /\ m > 0) -> exists (m : nat), P (Datatypes.S m).
Proof.
move => P [m [? ?]].
exists (Nat.pred m).
have : Datatypes.S (Nat.pred m) = m by omega.
by move => ->.
Qed.

Lemma finite_functional_choice : forall (f : nat -> formula) (xs : list nat),
  Forall (fun x => exists (m : nat), interpretation (f x) (1 + m)) xs
  -> exists g : (nat -> nat), Forall (fun x => interpretation (f x) (1 + g x)) xs.
Proof.
move => f. elim.
intros. exists (fun _ => 0). intros. done.

move => x xs IH. move /Forall_cons_iff.
move => [[m ?]]. move /IH => [g H_g].

exists (fun x' => if x' =? x then m else g x').
constructor. by inspect_eqb.

apply : Forall_impl; last eassumption.
move => x'. cbn.

case : (Nat.eq_dec x x'); intro; inspect_eqb; by subst.
Qed.

Ltac egalize_interpretation :=
  match goal with
  [H1 : interpretation ?s ?m1, H2 : interpretation ?s ?m2 |- _] =>
    tryif have ? : m1 = m2 by done then fail else have ? := interpretation_soundness H1 H2
  end.

Theorem soundness : forall (n : nat) (ΓU ΓS ΓP : list formula),
  (forall (s : formula), In s ΓU -> represents_nat s) ->
  (forall (s : formula), In s ΓS -> encodes_sum s) ->
  (forall (s : formula), In s ΓP -> encodes_prod s) ->
  forall (ds : list diophantine),
  normal_derivation n ((Encoding.ΓI ds) ++ ΓU ++ ΓS ++ ΓP) Encoding.triangle ->
  Diophantine.solvable ds.
Proof.
have ? := interpretation_one.
elim /lt_wf_ind => n IH.

intros * => HU HS HP ds ?.
decompose_normal_derivation.
gimme In; case => [? | H_In].
subst.
gimme chain. move /chain_intro_sum => [s1 [s2 [s3 [s4 [s5 ?]]]]]. subst.
decompose_Forall. do ? decompose_USP.
gimme normal_derivation; inversion.
gimme normal_derivation. move /(normal_weakening (Δ := (ΓI ds ++ ΓU ++ (S s1 s4 s5 :: ΓS) ++ ΓP))).
move /(_ ltac:(clear; list_inclusion)).
apply /IH; try eassumption + omega.

(*show that S s1 s4 s5 encodes sum*)
intro; case; last eauto.
intro; subst. apply : encodes_sum_intro; eassumption + lia.
(*shown Gamma S inductive case*)

(*NEXT: Gamma U inductive case*)
case : H_In => [? | H_In].
subst. gimme chain. move /chain_intro_element => [s [? ?]]; subst.
decompose_Forall. do ? decompose_USP.
match goal with [_ : interpretation s ?s_m |- _] => rename s_m into m end.

gimme normal_derivation; inversion.

pose sm' := represent_nat (Datatypes.S m).
gimme where normal_derivation. move /(_ (get_label sm')).
(*simplify goal type*)
autorewrite with simplify_formula => ?.

do 3 (gimme normal_derivation; inversion).
gimme normal_derivation. move /(normal_weakening (Δ := (ΓI ds ++ (U sm' :: ΓU) ++ (S s one sm' :: ΓS) ++ (P sm' one sm' :: ΓP)))).
move /(_ ltac:(clear; list_inclusion)).

apply /IH; first omega.
1-3 : intro; case; last eauto.
1-3 : intro; subst.

apply : represents_nat_intro; [reflexivity | lia].
apply : encodes_sum_intro; try eassumption + apply : interpretation_of_representation + lia.
apply : encodes_prod_intro; try eassumption + apply : interpretation_of_representation + lia.

(*shown Gamma U inductive case*)
(*NEXT: Gamma P inductive case*)
case : H_In => [? | H_In].

subst.
gimme chain. move /chain_intro_prod => [s1 [s2 [s3 [s4 [s5 ?]]]]]. subst.
decompose_Forall. do ? decompose_USP.
gimme normal_derivation; inversion.
gimme normal_derivation. move /(normal_weakening (Δ := (ΓI ds ++ ΓU ++ ΓS ++ (P s1 s4 s5 :: ΓP)))).
move /(_ ltac:(clear; list_inclusion)).
apply /IH; try eassumption + omega.

(*show that P s1 s4 s5 encodes prod*)
intro; case; last eauto.
intro; subst. apply : encodes_prod_intro; eassumption + nia.

case : H_In => [? | H_In].
(*lettuce show s_x_d ds*)
subst.
gimme chain.
move /inspect_chain_diophantines => [f H_f].
gimme Forall; move /Forall_tl. gimme @eq where tl. move => ->.
move /Forall_flat_map. move => Hds.

have : Forall (fun x => exists (m : nat),
  interpretation (f x) (1+m)) (flat_map Diophantine.variables ds).
{
rewrite Forall_forall.
move => x.
rewrite in_flat_map. move => [d [? ?]].
gimme where (In d ds).
gimme where normal_derivation. move //.
revert dependent d. case; cbn; intros.
1-3 : decompose_Forall.
1-3 : do ? decompose_USP.
1-3 : apply : exists_succ.
1-3 : intuition subst; eexists; eauto.
}

move /finite_functional_choice.

move => [g ?].

constructor. exists g. apply Forall_forall => d Hdds.
move : (Hdds). gimme Forall. move /Forall_flat_map. move //.
move : Hdds. gimme where normal_derivation. move //.
case d; cbn.
1-3 : intros.
1-3 : decompose_Forall.
1-3 : do ? decompose_USP.
1-3 : do ? egalize_interpretation.
1-3 : by inspect_eqb.

case /(@in_app_or formula): H_In => [|H_In].
move /HU => [? [? ?]]; subst; decompose_chain.
case /(@in_app_or formula): H_In.
move /HS => [? [? [? [? ?]]]]; subst; decompose_chain.
move /HP => [? [? [? [? ?]]]]; subst; decompose_chain.
Qed.