(* 集合型関数 と タクティクによる関数定義 *)
(* 2011_01_22 *)

(*
   述語判定関数は、集合型関数の特別な形。
   Nat の <や<= は、sumbool型の述語判定関数である。
   coq_sumbool.v
   *)
(*
   DefinitionやLemmaなど、定義の開始は何を使っても同じである。
   違いが出るのは閉じるところだけである。

   DefinedとQedは、どちらも証明を閉じ、
   作成されたGallina項を変数に束縛するものである（変数定義）。
   但し以下のような違いがある。

   ・Defined：変数定義は透過的(Transparent)である。
   即ち、変数に関連付けた項を参照するおとはできる。したがって、計算することができる。

   ・Qed：変数定義は非透過的(Opaque)である。変数に関連付けた項は参照できない。
   （従って計算することはできない。）変数の型のみを参照できる。
   *)

Require Import List.
Inductive app : forall T, list T -> list T -> list T -> Prop :=
| app_nil : forall T xs, app T nil xs xs
| app_one : forall T a xs ys zs, app T xs ys zs -> app T (a :: xs) ys (a :: zs).

(**************)
(* 集合型関数 *)
(**************)
Definition                                  (* Lamma でもよい *)
  safe_append (T : Type) (xs ys : list T) :
  {zs : list T | app T xs ys zs}.
Proof.
  intros.
  induction xs.
  exists ys.
  apply app_nil.

  case IHxs.
  intros zs H.
  exists (a :: zs).
  apply app_one.
  apply H.
Defined.                                    (* Qed で閉じると計算されない *)

Definition append (T : Type) (a b : list T) := proj1_sig (safe_append T a b).
Eval cbv in append nat (1::2::3::nil) (4::5::6::nil).
(*
   safe_append自体をEvalても、引数が展開されるだけで、計算（簡約）されない。
   Qedで閉じると、safe_append が見えてしまい、やはり計算されない。
*)
(* coq_safety_prog.v も参照のこと。*)

(****************************)
(* タクティクによる関数定義 *)
(****************************)
Definition                                  (* Lamma でもよい *)
  append2 (T : Type) (xs ys : list T) : list T.
Proof.
  intros.
  induction xs.
  apply ys.
  apply cons.
  apply a.
  apply IHxs.
Defined.                                    (* Definedで閉じること *)
Eval cbv in append2 nat (1::2::3::nil) (4::5::6::nil).
Print append2.

(* 上と同じ定義を refine で書いた *)

Definition                                  (* Lamma でもよい *)
  append3 (T : Type) (xs ys : list T) : list T.
Proof.
  refine
    (fun (T : Type) (xs ys : list T) =>
      list_rect (fun _ : list T => list T) ys
      (fun (a : T) (_ IHxs : list T) => a :: IHxs) xs).
Defined.                                    (* Definedで閉じること *)
Eval cbv in append3 nat (1::2::3::nil) (4::5::6::nil).

(******************)
(* 通常の関数定義 *)
(******************)
Fixpoint append4 (T : Type) (xs ys: list T) : list T :=
  match xs with
    | nil => ys
    | x :: xs => x :: (append4 T xs ys)
  end.
Eval cbv in append4 nat (1::2::3::nil) (4::5::6::nil).

(* END *)


Set Implicit Arguments.
Unset Strict Implicit.

Require Import QArith String Ascii ProofIrrelevance List.
Require VectorDef.

(*The computable state representation is an FMap over
  player indices, represented as positive.*)
Require Import Coq.FSets.FMapAVL Coq.FSets.FMapFacts.
Require Import Structures.Orders NArith.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.

Require Import OUVerT.strings compile orderedtypes
        OUVerT.dyadic OUVerT.numerics MWU.weightsextract
        OUVerT.vector.

Module Winnow (NumFeatures : BOUND) (NumConstraints : BOUND).
  Module Constraints := DConstraintMatrix NumFeatures NumConstraints. Import Constraints.
  Notation constraint := Constraint.t.
  Notation A := CMatrix.t.
  Notation weights := Vec.t.

  Definition DRed_of_label (l : Constraint.label) := (if l then 1 else -(1))%DRed.
  Coercion DRed_of_label : Constraint.label >-> DRed.t.

  Definition interp_constraint (c : Constraint.t) : Vec.t :=
    let: (v, l) := c in
    Vec.map0 (fun _ x => (l*x)%DRed) v.

  Definition unsatisfied (w : weights) (cs : A) : option (CMatrix.Ix.t * constraint) :=
    CMatrix.any
      (fun i c =>
         if Dlt_bool (dot_product (interp_constraint c) w) 0 then Some c
         else None)
      cs.

  Definition rho (cs : A) : DRed.t :=
    CMatrix.fold0
      (fun i c (acc : DRed.t) =>
         let m := linf_norm (interp_constraint c) in
         if Dlt_bool acc m then m else acc)
      cs
      0%DRed.

  Section winnow.
    Variable cs : A.
    Variable eps : DRed.t. (* TODO: calculatable from rho *)
    Variable num_rounds : N.t. (* TODO: calculatable from rho *)

    (* 1 / smallest power of two greater than [rho cs] *)
    Definition inv_rho : DRed.t := DRed.lub (rho cs).

    Definition cost_vector_of_unsatisfied (v : Vec.t) : Vec.t :=
      Vec.map0 (fun i a => (inv_rho * -a)%DRed) v.

    Definition init_cost_vector : Vec.t :=
      Vec.of_fun (fun _ => 1%DRed).

    Definition cost_vector (w : weights) : Vec.t :=
      match unsatisfied w cs with
      | None => init_cost_vector
      | Some c => cost_vector_of_unsatisfied (interp_constraint c.2)
      end.

    Definition state : Type := Vec.t.
    Definition init_state : state := Vec.of_fun (fun _ => 0%DRed).

    Definition chanty : Type := unit.
    Definition bogus_chan : chanty := tt.

(** NEEDS UPDATING:
  Definition weight_vector_of_list (l : list (M.t*D)) : state :=
    let gamma :=
        List.fold_left
          (fun acc (p : M.t*D) =>
             let (_, d) := p in
             (d + acc)%D)
          l
          0%D
    in
    VectorDef.map
      (fun i =>
         match findA (fun j => i===j) l with
         | None => 0%D
         | Some d => (Dlub gamma * d)%D
         end)
      index_vec.

  Definition send (st : state) (l : list (M.t*D)) : (chanty*state) :=
    (bogus_chan, weight_vector_of_list (print_Dvector l l)).

  Definition recv (st : state) (_ : chanty) : (list (M.t*D) * state) :=
    (cost_vector st, st).

  Program Definition lp_client_oracle : @ClientOracle M.t :=
    @mkOracle
      M.t
      state
      init_state
      chanty
      bogus_chan
      recv
      send
      _
      _.
  Next Obligation.
  Next Obligation.

  (** Hook up to MWU *)

  Existing Instance lp_client_oracle.

  Require Import weightsextract.

  Module MWU := MWU M.

  Definition mwu :=
    MWU.interp
      (weightslang.mult_weights M.t P.num_rounds)
      (MWU.init_cstate P.eps).
End LP.

(** TEST 1 *)

Module P : LINEAR_PROGRAM.
  Definition n : nat := 1.
  Lemma n_gt0 : (0 < n)%N. Proof. by []. Qed.
  Definition num_constraints : nat := 2.

  Definition cs : A n num_constraints :=
    let c1 : constraint 2 :=
        (VectorDef.cons _ (-(Dmake 3 1))%D _ (VectorDef.cons _ 1%D _ (VectorDef.nil _)), true) in
    let c2 : constraint 2 :=
        (VectorDef.cons _ 1%D _ (VectorDef.cons _ (-(Dmake 3 1))%D _ (VectorDef.nil _)), true) in
    let c3 : constraint 2 :=
        (VectorDef.cons _ 1%D _ (VectorDef.cons _ (-(Dmake 1 2))%D _ (VectorDef.nil _)), false) in
    let c4 : constraint n := (VectorDef.cons _ (-(1))%D _ (VectorDef.nil _), true) in
    let c5 : constraint n := (VectorDef.cons _ (1)%D _ (VectorDef.nil _), false) in
    VectorDef.cons _ c5 _ (VectorDef.cons _ c4 _ (VectorDef.nil _)).

  Definition eps := Dmake 1 2. (* eps = 1/4 *)
  Definition num_rounds : N.t := 50.
End P.

Module LP_P := LP P.

Unset Extraction Optimize.
Unset Extraction AutoInline.

Extraction "runtime/lp.ml" LP_P.mwu.
*)

  End winnow.
End Winnow.


Require Export StlcFix.Inst.
Require Export Coq.Relations.Relation_Operators.
Require Export Common.Relations.
Require Export StlcFix.SpecEvaluation.
Require Export StlcFix.LemmasEvaluation.

Require Import Lia.

Fixpoint size (t : Tm) : nat :=
  match t with
  | var i => 1
  | abs τ t => 1
  | app t₁ t₂ => S (size t₁ + size t₂)
  | unit => 1
  | true => 1
  | false => 1
  | ite t₁ t₂ t₃ => S (size t₁ + size t₂ + size t₃)
  | pair t₁ t₂ => S (size t₁ + size t₂)
  | proj₁ t => S (size t)
  | proj₂ t => S (size t)
  | inl t => S (size t)
  | inr t => S (size t)
  | caseof t₁ t₂ t₃ => S (size t₁ + size t₂ + size t₃)
  | seq t₁ t₂ => S (size t₁ + size t₂)
  | fixt τ₁ τ₂ t => S (size t)
  end.

(* Hor is for horizon: no terms should be hidden behind the horizon n *)
Inductive evalHor (t1 : Tm) : Tm -> nat -> Prop :=
  | evalHor_term : forall n, size t1 <= n -> evalHor t1 t1 n
  | evalHor_step : forall t2 t3 n,
      size t1 <= n -> eval t1 t2 -> evalHor t2 t3 n -> evalHor t1 t3 (S n)
.
#[export]
Hint Constructors evalHor : eval.

Definition TermHor (t1 : Tm) (n : nat) :=
  exists v, Value v /\ evalHor t1 v n.

Lemma TermHor_size {t n} : TermHor t n -> size t <= n.
Proof.
  destruct 1 as (v & vv & eh).
  destruct eh as [n st|t2 t3 n st e eh]; lia.
Qed.

Lemma evalHor_lt {t1 t2 n} :
  evalHor t1 t2 n -> forall n', n <= n' -> evalHor t1 t2 n'.
Proof.
  induction 1; intros n' ineq.
  - eapply evalHor_term; [lia].
  - destruct n'; [exfalso;lia|].
    eapply evalHor_step; [lia|eauto|].
    eapply IHevalHor; lia.
Qed.

Lemma TermHor_lt {t n n'} :
  TermHor t n → n ≤ n' → TermHor t n'.
Proof.
  destruct 1 as (v & vv & eh).
  intros ineq.
  exists v; split; try assumption.
  eauto using evalHor_lt.
Qed.

Lemma termHor_closed_under_antireduction {t t' n} :
  t --> t' → size t <= n -> TermHor t' n → TermHor t (S n).
Proof.
  destruct 3 as (v & vv & steps).
  exists v; eauto using evalHor_step.
Qed.

Lemma TermHor_closed_under_reduction {t t' n} :
  t --> t' → TermHor t (S n) -> TermHor t' n.
Proof.
  intros step term.
  destruct term as (v & vv & steps).
  exists v; split; try assumption.
  remember (S n) as n'.
  destruct steps.
  + exfalso.
    eapply values_are_normal; eauto.
  + destruct (determinacy step H0).
    inversion Heqn'.
    now destruct H2.
Qed.

Lemma TermHor_closed_under_reduction_star {t t' n} :
  t -->* t' → TermHor t n -> TermHor t' n.
Proof.
  induction 1;
  eauto using TermHor_closed_under_reduction, TermHor_lt.
Qed.

Lemma TermHor_eval_extend {t t' n} :
  t --> t' → size t <= n -> TermHor t' n <-> TermHor t (S n).
Proof.
  intros term.
  split; eauto using termHor_closed_under_antireduction, TermHor_closed_under_reduction.
Qed.

Lemma TermHor_evalHor {t t' n } :
  evalHor t t' n → forall n', TermHor t' n' -> TermHor t (n + n').
Proof.
  induction 1; intros n' term.
  - eapply (TermHor_lt term); lia.
  - change (S n + n') with (S (n + n')).
    eapply (termHor_closed_under_antireduction H0).
    + lia.
    + eauto using IHevalHor.
Qed.

Lemma TermHor_xor_evaln {t t' n} :
  TermHor t n → evaln t t' (S n) → False.
Proof.
  intros term esn.
  destruct term as (v & vv & steps).
  revert esn.
  induction steps; intros esn.
  - destruct (evaln_split1 esn) as (t2 & step & steps').
    exact (values_are_normal vv _ step).
  - destruct (evaln_split1 esn) as (t4 & step & steps').
    destruct (determinacy H0 step).
    exact (IHsteps vv steps').
Qed.

Lemma TermHor_evaln {t t' n } n' :
  evaln t t' n → TermHor t (n + n') -> TermHor t' n'.
Proof.
  intros steps term.
  induction steps; eauto.
  eapply IHsteps.
  now apply (TermHor_closed_under_reduction H term).
Qed.

Lemma evalHor_evaln {t t' n} :
  evalHor t t' n -> exists n', n' <= n /\ evaln t t' n'.
Proof.
  induction 1.
  exists 0; repeat split.
  - lia.
  - constructor.
  - destruct IHevalHor as (n' & ineq & es).
    exists (S n'); split.
    + lia.
    + now eapply (stepRel_step eval _ _ _ _ H0).
Qed.

Lemma TermHor_TerminatingN {t n} :
  TermHor t n -> TerminatingN t n.
Proof.
  destruct 1 as (v & vv & es).
  destruct (evalHor_evaln es) as (n' & ineq & es').
  exists v,n'; eauto.
Qed.

Lemma TermHor_Terminating {t n} :
  TermHor t n -> Terminating t.
Proof.
  eauto using TermHor_TerminatingN, TerminatingN_Terminating.
Qed.

Lemma evalStar_to_evalHor {t t'} : evalStar t t' -> exists n, evalHor t t' n.
Proof.
  induction 1.
  - exists (size x).
    constructor; eauto.
  - destruct IHclos_refl_trans_1n as (n & es).
    exists (S (n + size x)).
    eapply evalHor_step.
    + lia.
    + eauto.
    + eapply evalHor_lt; eauto; lia.
Qed.

Lemma Terminating_TermHor {t : Tm} : t ⇓ -> ∃ n, TermHor t n.
Proof.
  destruct 1 as (v & vv & es).
  destruct (evalStar_to_evalHor es) as [n en].
  exists n; econstructor; eauto.
Qed.

Lemma size_value_gt_zero {t : Tm} : Value t -> size t > 0.
Proof.
  destruct t; cbn; intuition.
Qed.

Lemma size_ectx {t} C : ECtx C -> size t <= size (pctx_app t C).
Proof.
  induction C; try contradiction;
    try reflexivity;
    intros eC; try (cbn; specialize (IHC eC); lia);
  cbn; destruct eC as [vt eC];
  specialize (IHC eC); lia.
Qed.

(* convenience lemma *)
Lemma size_ectx' {t w} C : ECtx C -> size (pctx_app t C) <= w -> size t <= w.
Proof.
  eauto using size_ectx with arith.
Qed.

Lemma evalHor_ectx_inv C {t} (ec : ECtx C) {v n} :
  evalHor (pctx_app t C) v n → Value v →
  exists v', Value v' ∧ t -->* v' ∧ evalHor (pctx_app v' C) v n.
Proof.
  intros es vv; depind es.
  - exists t; eauto using value_ectx_inv with eval.
  - destruct (eval_ectx_inv C t ec H0 eq_refl) as [vt|[t'' [eq e]]].
    + exists t; eauto with eval.
    + subst.
      destruct (IHes t'' C ec eq_refl vv) as (v' & vv' & es1' & es2').
      eapply evalHor_lt in es2'.
      exists v'; eauto with eval.
      lia.
Qed.

Lemma TermHor_ectx_inv C {t} (ec : ECtx C) {n} :
  TermHor (pctx_app t C) n →
  exists v', Value v' ∧ t -->* v' ∧ TermHor (pctx_app v' C) n.
Proof.
  intros (v & vv & es).
  destruct (evalHor_ectx_inv C ec es vv) as (v' & vv' & es1 & es2).
  exists v'. repeat split; auto.
  exists v. eauto.
Qed.


Require Import prosa.classic.model.time prosa.classic.util.all.
From mathcomp Require Import ssrnat ssrbool eqtype fintype seq.

(* Attributes of a valid sporadic task. *)
Module SporadicTask.

  Import Time.

  Section BasicTask.
    Context {Task: eqType}.
    Variable task_cost: Task -> time.
    Variable task_period: Task -> time.
    Variable task_deadline: Task -> time.

    Section ValidParameters.
      Variable tsk: Task.

      (* The cost, period and deadline of the task must be positive. *)
      Definition task_cost_positive := task_cost tsk > 0.
      Definition task_period_positive := task_period tsk > 0.
      Definition task_deadline_positive := task_deadline tsk > 0.

      (* The task cost cannot be larger than the deadline or the period. *)
      Definition task_cost_le_deadline := task_cost tsk <= task_deadline tsk.
      Definition task_cost_le_period := task_cost tsk <= task_period tsk.

      Definition is_valid_sporadic_task :=
        task_cost_positive /\ task_period_positive /\ task_deadline_positive /\
        task_cost_le_deadline /\ task_cost_le_period.

    End ValidParameters.

  End BasicTask.

End SporadicTask.

(* Definition and properties of a task set. *)
Module SporadicTaskset.
  Import Time.
  Export SporadicTask.

  Section TasksetDefs.

    (* A task set is defined as a {set ...}, which denotes a sequence
       of tasks with no duplicates. *)
    Definition taskset_of (Task: eqType) := {set Task}.

    (* Next, we define some properties abouts sequences of tasks. *)
    Section TasksetProperties.

      Context {Task: eqType}.
      Variable task_cost: Task -> time.
      Variable task_period: Task -> time.
      Variable task_deadline: Task -> time.

      Let is_valid_task :=
        is_valid_sporadic_task task_cost task_period task_deadline.

      Variable ts: seq Task.

      (* A valid sporadic taskset only contains valid tasks. *)
      Definition valid_sporadic_taskset :=
        forall tsk,
          tsk \in ts -> is_valid_task tsk.

      (* A task set can satisfy one of three deadline models:
         implicit, constrained, or arbitrary. *)
      Definition implicit_deadline_model :=
        forall tsk,
          tsk \in ts -> task_deadline tsk = task_period tsk.

      Definition constrained_deadline_model :=
        forall tsk,
          tsk \in ts -> task_deadline tsk <= task_period tsk.

      Definition arbitrary_deadline_model := True.

    End TasksetProperties.

  End TasksetDefs.

End SporadicTaskset.


Require Import String.
Open Scope string_scope.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Compute eqb_string "A" "A".

(* Environment *)

Inductive Value :=
| undef : Value
| nat_value : nat -> Value
| bool_val : bool -> Value.

Coercion nat_value : nat >-> Value.

Scheme Equality for Value.

Inductive Variables :=
| simple: string -> Variables
| array: string -> nat -> Variables.

Scheme Equality for Variables.

Notation "A '[:' B ']'" := (array A B) (at level 40).
Coercion simple : string >-> Variables.
Compute "a"[: 5].

Definition Env := Variables -> Value.

Definition env0 : Env :=
   fun (s : Variables) => undef.

Compute (env0 "C").

Definition is_declared (x : Variables) (env : Env) :=
 if (Value_beq (env x) undef)
 then false
 else true.

Compute is_declared "C" env0.

Definition update (env : Env)
           (x : Variables) (v : nat) :=
  fun y =>
    if (Variables_beq y x)
    then nat_value v
    else (env y).

Definition env1 := update env0 "n" 10.

Compute env1 "n".

Notation "S [ V /' X ]" := (update S X V) (at level 0).

Definition env2 := env1 [ 1045 /' "n" ].
Compute (env2 "n").

Definition adress := string -> nat.

(*Exemplu*)
Definition adr : adress :=
   fun (s : string) => 0.

Compute adr "s".

Definition adress_env :=
   fun (s : string) => adr s.
Compute (adress_env "s").

Definition array_env := nat -> Value. (* adresa -> valoare*)
             (*a [: 5] -> valoarea pe care o intalnesc la (adresa lui a) +5*)

(*Exemplu*)
Definition array_env0 : array_env :=
    fun (adr : nat) => undef.

Definition update_array (a : array_env)
           (adr : nat) (v : nat) :=
  fun y =>
    if (Nat.eqb y adr)
    then nat_value v
    else (a y).

Definition literal := nat -> nat.

Inductive AExp :=
| aliteral : nat -> literal -> AExp
| alambda_call : string -> nat -> AExp
| avar : Variables -> AExp
| anum : nat -> AExp
| aplus : AExp -> AExp -> AExp
| adif: AExp ->AExp -> AExp
| amul : AExp -> AExp -> AExp.

Notation "f '_(' n ')_'" := (alambda_call f n) (at level 40).
Notation "A '_lit' lit" := (aliteral A lit) (at level 40).
Notation "A +' B" := (aplus A B) (at level 48).
Notation "A *' B" := (amul A B) (at level 46).
Notation "A -' B" := (adif A B) (at level 48).
Coercion anum : nat >-> AExp.
Coercion avar : Variables >-> AExp.

(*Exemple*)

Compute "f"_( 3 )_.
Definition literal1 : literal :=
   fun (n: nat) => n+3.

Check 3 _lit literal1.
Check (2 +' 3 *' 5).
Check (2 +' 3 *' "n").
Check "a"[:3] +' 5.
Check 3 +'  "a"[:10].

Inductive BExp :=
| btrue : BExp
| bfalse : BExp
| blessthan : AExp -> AExp -> BExp
| bnot : BExp -> BExp
| band : BExp -> BExp -> BExp.

Notation "A <=' B" := (blessthan A B) (at level 53).

Inductive Stmt :=
| def : Variables -> nat -> Stmt
| decl : Variables -> Stmt
| decl_lambda_expr : string -> Variables -> AExp -> Stmt
| assignment : string -> AExp -> Stmt
| initializer_list : string -> list nat -> Stmt
| break : Stmt
| sequence : Stmt -> Stmt -> Stmt
| while : BExp -> Stmt -> Stmt
| ifthen : BExp -> Stmt -> Stmt
| ifthenelse: BExp -> Stmt -> Stmt -> Stmt
| For : Stmt -> BExp -> Stmt -> Stmt -> Stmt.

Notation "'int' X" := (decl X) (at level 50).
Notation "'auto' s '[=]' x 'Return' S 'End'" := (decl_lambda_expr s x S) (at level 50).
Notation "X ::= A" := (assignment X A) (at level 50).
Notation "S1 ;; S2" := (sequence S1 S2) (at level 90, right associativity).
Notation "'If' A 'Then' B 'Else' C 'End'" := (ifthenelse A B C)(at level 97).
Notation "'If' A 'Then' B 'End'" := (ifthen A B)(at level 97).
Notation "'For(' A ';;;' B ';;;' C ')Do' D" := (For A B C D )(at level 98).
Notation "'#define' A B" := (def A B) (at level 50, A at level 9).

Definition is_break_on (env: Env) :=
if (Value_beq (env "Break") 0)
then false
else true.

(*Exemplu*)
Definition env3 := update env0 "Break" 0.
Compute is_break_on env3.

Compute #define "MAX" 1000.

Compute For( "i"::=1 ;;; "i"<=' "n" ;;; "i"::= "i" +' 1 )Do
        "sum"::= "sum" +' 1.
Compute int "c".
Compute int "c"[: 5].

(*Totodata, pentru pentru a evita folosirea ghilimelelor de fiecare data,
am definit string-urile folosite in programele de mai jos*)

Definition x : string := "x".
Definition a : string := "a".
Definition n : string := "n".
Definition i : string := "i".
Definition sum := "sum".

Compute
  #define "MAX" 1000;;
  auto "f" [=] (x) Return (x +' 3) End;;
  int a[: 2];;
  int n;;
  int i;;
  int sum;;
  sum ::= "f"_( 3 )_;;
  initializer_list a (cons 1 (cons 2 nil));;
  n ::= 1 _lit literal1 ;;
  i ::= a[: 0] ;;
  sum ::= 0 ;;
  while ( i <=' n ) (
          sum ::= sum +' i ;;
          i ::= i +' 1;;
          break
        );;
  If ( i <=' n ) Then
                     ( sum ::= sum +' i ;;
                     i ::= i +' 1 )
  Else (sum ::= 0)
  End;;
  If ( i <=' n ) Then
                     ( sum ::= sum +' i ;;
                     i ::= i +' 1 )
  End;;
  For( i ::= 2 ;;; i<=' n ;;; i ::= i+'1 )Do
          sum ::= sum +' i.

(* Definition init_list := list nat.
Definition list1 : list nat := cons 1 (cons 2 nil).
Compute list1.

Fixpoint suma (l1 : list nat) : nat :=
match l1 with
| nil => 0
| cons n l => n + (suma l)
end.

Compute suma list1.

Definition adr1 : adress :=
   fun s =>
    if (eqb_string s "a")
    then 1000
    else 0.
Compute adr1 "a".

Definition array_val1 := update_array array_val 1000 1.
Compute array_val1 1000.

Fixpoint initializer_list<int> (s : string) (adr : nat) (a : array_env) (l : list nat) :=
match l with
| cons n nil =>
| cons n l => a
end *)


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith Lia.

From Undecidability.Shared.Libs.DLW
  Require Import utils godel_coding pos vec sss compiler_correction.

From Undecidability.MinskyMachines.MMA
  Require Import mma_defs mma_k_mma_2_compiler.

Set Default Goal Selector "!".

#[local] Notation "e #> x" := (vec_pos e x).

Section mma3_mma2_compiler.

  Variable n : nat.

  Let simul (v : vec nat (3+n)) (w : vec nat (2+n)) : Prop :=
        w#>pos0 = 0
     /\ w#>pos1 = gc_enc godel_coding_235 (fst (vec_split _ _ v))
     /\ forall x, v#>(pos_right _ x) = w#>(pos_right _ x).

  Theorem mma3_mma2_compiler : compiler_t (@mma_sss _) (@mma_sss _) simul.
  Proof.
    generalize (mma_k_mma_2_compiler godel_coding_235 n).
    apply compiler_t_simul_equiv.
    intros v w.
    generalize (vec_app_split _ _ v) (vec_app_split _ _ w).
    destruct (vec_split _ _ v) as (v1,v2).
    destruct (vec_split _ _ w) as (w1,w2).
    intros <- <-.
    assert (v1 = v1#>pos0##v1#>pos1##v1#>pos2##vec_nil) as E.
    1: apply vec_pos_ext; intros p; repeat invert pos p; auto.
    unfold simul; split; simpl.
    + intros (-> & ->); msplit 2; rew vec; simpl; f_equal; auto.
    + intros (H1 & H2 & H3); split.
      * apply vec_pos_ext; intros p; repeat invert pos p; auto.
        rewrite H2; f_equal; auto.
      * apply vec_pos_ext; intros p.
        generalize (H3 p); rew vec.
  Qed.

End mma3_mma2_compiler.


Require Import Grph.Graph.
Require Import Cat.Category.
Require Import Coq.Program.Basics.
Require Import Coq.Logic.Classical_Prop.

Inductive Grph : Type :=
    grph (V A : Type) (g : Graph V A) : Grph.

Arguments grph {V A} g.

Definition vert_of (X : Grph) : Type :=
    match X with grph V _ _ => V end.

Definition arr_of (X : Grph) : Type :=
    match X with grph _ A _ => A end.

Definition graph_of (g : Grph) : Graph (vert_of g) (arr_of g) :=
    match g with grph _ _ g => g end.

Definition src_of (X : Grph) : arr_of X -> vert_of X :=
    match X with grph _ _ g => match g with graph src _ => src end end.

Definition tgt_of (X : Grph) : arr_of X -> vert_of X :=
    match X with grph _ _ g => match g with graph _ tgt => tgt end end.

Inductive GrphHom (X Y : Grph) : Type :=
    grph_hom
        (vert_fn : vert_of X -> vert_of Y)
        (arr_fn : arr_of X -> arr_of Y)
        (proof_src : compose (src_of Y) arr_fn = compose vert_fn (src_of X))
        (proof_tgt : compose (tgt_of Y) arr_fn = compose vert_fn (tgt_of X))
            : GrphHom X Y.

Definition vert_fn {X Y : Grph} (g : GrphHom X Y) : vert_of X -> vert_of Y :=
    match g with grph_hom v _ _ _ => v end.

Definition arr_fn {X Y : Grph} (g : GrphHom X Y) : arr_of X -> arr_of Y :=
    match g with grph_hom _ a _ _ => a end.

Theorem grph_hom_eq {X Y : Grph} {f g : GrphHom X Y} :
        vert_fn f = vert_fn g -> arr_fn f = arr_fn g -> f = g.
    intros proof_v proof_a.
    destruct f as [vf af psf ptf].
    destruct g as [vg ag psg ptg].
    simpl in *.
    subst.
    f_equal; apply proof_irrelevance.
Qed.

Definition id_grph (X : Grph) : GrphHom X X.
    refine (grph_hom X X id id _ _);
        reflexivity.
Defined.

Definition comp_grph (X Y Z : Grph) (f : GrphHom Y Z) (g : GrphHom X Y) : GrphHom X Z.
    refine (grph_hom X Z (compose (vert_fn f) (vert_fn g)) (compose (arr_fn f) (arr_fn g)) _ _);
        destruct f as [vf af psf ptf]; destruct g as [vg ag psg ptg];
        simpl in *;
        [
            pose (fn := src_of); pose (proof_f := psf); pose (proof_g := psg) |
            pose (fn := tgt_of); pose (proof_f := ptf); pose (proof_g := ptg)
        ];
        assert (chase1 : compose (fn Z) (compose af ag) = compose (compose (fn Z) af) ag) by trivial;
        assert (chase2 : compose (compose vf vg) (fn X) = compose vf (compose vg (fn X))) by auto;
        unfold fn in *;
        rewrite chase1;
        rewrite chase2;
        rewrite proof_f;
        rewrite <- proof_g;
        reflexivity.
Defined.

Instance GrphIsCat : Category id_grph comp_grph.
    split;
        intros;
        apply grph_hom_eq;
        reflexivity.
Qed.

Definition GrphCat : Cat :=
    cons_cat Grph GrphHom id_grph comp_grph GrphIsCat.


Require Export ProjectiveGeometry.Dev.projective_plane_axioms.

(**  PG(2,3). **)

(** To show that our axiom system is consistent we build a finite model. **)

Section s_fanoPlaneModelPG23Generated.

(** We define point and line by an inductive type representing the thirteen possibilities. **)
(** We can not use directly the inductive type for a technical reason related to Coq's implementation. **)

Inductive ind_Point : Set := p0 | p1 | p2 | p3 | p4 | p5 | p6 | p7 | p8 | p9 | p10 | p11 | p12.

Inductive ind_line : Set := l0 | l1 | l2 | l3 | l4 | l5 | l6 | l7 | l8 | l9 | l10 | l11 | l12.

Definition Point : Set := ind_Point.
Definition Line : Set := ind_line.

Definition Incid_bool : Point -> Line -> bool := fun P l =>
 match P with
| p0 =>
	match l with
	| l3| l9| l11| l12=> true
	| _ => false
	end
| p1 =>
	match l with
	| l0| l4| l10| l12=> true
	| _ => false
	end
| p2 =>
	match l with
	| l0| l1| l5| l11=> true
	| _ => false
	end
| p3 =>
	match l with
	| l1| l2| l6| l12=> true
	| _ => false
	end
| p4 =>
	match l with
	| l0| l2| l3| l7=> true
	| _ => false
	end
| p5 =>
	match l with
	| l1| l3| l4| l8=> true
	| _ => false
	end
| p6 =>
	match l with
	| l2| l4| l5| l9=> true
	| _ => false
	end
| p7 =>
	match l with
	| l3| l5| l6| l10=> true
	| _ => false
	end
| p8 =>
	match l with
	| l4| l6| l7| l11=> true
	| _ => false
	end
| p9 =>
	match l with
	| l5| l7| l8| l12=> true
	| _ => false
	end
| p10 =>
	match l with
	| l0| l6| l8| l9=> true
	| _ => false
	end
| p11 =>
	match l with
	| l1| l7| l9| l10=> true
	| _ => false
	end
| p12 =>
	match l with
	| l2| l8| l10| l11=> true
	| _ => false
	end
end.

Definition Incid : Point -> Line -> Prop := fun P L => (Incid_bool P L = true).

Hint Unfold Incid Incid_bool.

Lemma incid_dec : forall (A:Point) (l:Line), {Incid A l} + {~Incid A l}.
Proof.
intros.
unfold Incid.
elim l;elim A;unfold Incid_bool;simpl;auto;right;discriminate.
Qed.

Ltac solve_ex L := solve [exists L;auto].

(** A tactic which tries all possible lines **)
Ltac solve_ex_l := first [
        solve_ex l0
     |  solve_ex l1
     |  solve_ex l2
     |  solve_ex l3
     |  solve_ex l4
     |  solve_ex l5
     |  solve_ex l6
     |  solve_ex l7
     |  solve_ex l8
     |  solve_ex l9
     |  solve_ex l10
     |  solve_ex l11
     |  solve_ex l12
 ].

(** A tactic which tries all possible points **)
Ltac solve_ex_p := first [
        solve_ex p0
     |  solve_ex p1
     |  solve_ex p2
     |  solve_ex p3
     |  solve_ex p4
     |  solve_ex p5
     |  solve_ex p6
     |  solve_ex p7
     |  solve_ex p8
     |  solve_ex p9
     |  solve_ex p10
     |  solve_ex p11
     |  solve_ex p12
 ].

(** A1 : any two points lie on a unique line **)
Lemma a1_exist : forall ( A B :Point) ,{l:Line | Incid A l /\ Incid B l}.
Proof with auto.
intros.
elim A;elim B;solve_ex_l.
Qed.

Lemma degen_point: forall A:Point, forall P: Prop, ~A=A -> P.
Proof.
intuition.
Qed.

Lemma degen_line: forall A:Line, forall P: Prop, A<>A -> P.
Proof.
intuition.
Qed.

Ltac remove_degen := match goal with
| H: ~ ?A=?A |- ?G => apply (degen_point A G H)
| H: ?A<>?A |- ?G => apply (degen_line A G H)
end.

Lemma uniqueness : forall A B :Point, forall l m : Line,
 Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A=B\/l=m.
Proof.
intros P Q l m H1 H2 H3 H4.
 induction P; induction Q; try (left;reflexivity);
 induction l; try discriminate;
 induction m; try discriminate;try (left; reflexivity);try (right; reflexivity).
Qed.

Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
  ~A=B -> Incid A l1 -> Incid B l1 -> Incid A l2 -> Incid B l2 -> l1=l2.
Proof.
intros X Y l1 l2 HXY H1 H2 H3 H4.
induction X;induction Y; try remove_degen;
induction l1;try discriminate; induction l2; discriminate || reflexivity.
Qed.

Lemma a2_unique : forall(l1 l2 :Line)(A B :Point),
  ~l1=l2 -> Incid A l1 -> Incid A l2 -> Incid B l1 -> Incid B l2 -> A=B.
Proof.
intros l1 l2 X Y H H1 H2 H3 H4.
 induction X;induction Y;try reflexivity;
 induction l1;try discriminate;
 induction l2;try discriminate;try remove_degen.
Qed.

(** A2 : any two lines meet in a unique point **)
Lemma a2_exist : forall (l1 l2:Line), {A:Point | Incid A l1 /\ Incid A l2}.
Proof.
intros l1 l2.
induction l1;induction l2;solve_ex_p.
Qed.

(** A3 : there exist four points with no three collinear **)
Lemma a3 : {A:Point & {B :Point & {C:Point & {D :Point |
  (forall l :Line, ~A = B /\ ~A = C /\ ~A = D /\ ~B = C /\ ~B = D /\ ~C = D /\
    (Incid A l /\ Incid B l -> ~Incid C l /\ ~Incid D l)
    /\ (Incid A l /\ Incid C l -> ~Incid B l /\ ~Incid D l)
    /\  (Incid A l /\ Incid D l -> ~Incid C l /\ ~Incid B l)
    /\  (Incid C l /\ Incid B l -> ~Incid A l /\ ~Incid D l)
    /\ (Incid D l /\ Incid B l -> ~Incid C l /\ ~Incid A l)
    /\  (Incid C l /\ Incid D l -> ~Incid B l /\ ~Incid A l))}}}}.
Proof.
exists p1.
exists p2.
exists p6.
exists p11.
intros.
elim l;unfold Incid, Incid_bool;intuition;try discriminate.
Qed.

Instance ObjectPointFano : ObjectPoint := {
Point := Point
}.

Instance ProjectiveStructureFano : ProjectiveStructure ObjectPointFano := {
Line := Line;
Incid := Incid;
incid_dec := incid_dec
}.

Instance ProjectiveStructureLEFano : ProjectiveStructureLE ProjectiveStructureFano := {
a1_exist := a1_exist
}.

Instance ProjectiveStructureLEUFano : ProjectiveStructureLEU ProjectiveStructureLEFano := {
uniqueness := uniqueness
}.

Instance PreProjectivePlaneFano : PreProjectivePlane ProjectiveStructureLEUFano := {
a2_exist := a2_exist
}.

Instance ProjectivePlaneFano : ProjectivePlane PreProjectivePlaneFano := {
a3 := a3
}.

End s_fanoPlaneModelPG23Generated.


(* Make [omega] work for [N] *)

Require Import Arith Omega NArith.

Local Open Scope N_scope.

Hint Rewrite Nplus_0_r nat_of_Nsucc nat_of_Nplus nat_of_Nminus
  N_of_nat_of_N nat_of_N_of_nat
  nat_of_P_o_P_of_succ_nat_eq_succ nat_of_P_succ_morphism : N.

Theorem nat_of_N_eq : forall n m,
  nat_of_N n = nat_of_N m
  -> n = m.
Proof.
  intros ? ? H; apply (f_equal N_of_nat) in H;
    autorewrite with N in *; assumption.
Qed.

Theorem Nneq_in : forall n m,
  nat_of_N n <> nat_of_N m
  -> n <> m.
Proof.
  congruence.
Qed.

Theorem Nneq_out : forall n m,
  n <> m
  -> nat_of_N n <> nat_of_N m.
Proof.
  intuition.
Qed.

Theorem Nlt_out : forall n m, n < m
  -> (nat_of_N n < nat_of_N m)%nat.
Proof.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_Lt_lt; assumption.
Qed.

Theorem Nlt_in : forall n m, (nat_of_N n < nat_of_N m)%nat
  -> n < m.
Proof.
  unfold N.lt; intros.
  rewrite nat_of_Ncompare.
  apply (proj1 (nat_compare_lt _ _)); assumption.
Qed.

Theorem Nge_out : forall n m, n >= m
  -> (nat_of_N n >= nat_of_N m)%nat.
Proof.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare in H.
  apply nat_compare_ge; assumption.
Qed.

Theorem Nge_in : forall n m, (nat_of_N n >= nat_of_N m)%nat
  -> n >= m.
Proof.
  unfold N.ge; intros.
  rewrite nat_of_Ncompare.
  apply nat_compare_ge; assumption.
Qed.

Ltac nsimp H := simpl in H; repeat progress (autorewrite with N in H; simpl in H).

Ltac pre_nomega :=
  try (apply nat_of_N_eq || apply Nneq_in || apply Nlt_in || apply Nge_in); simpl;
    repeat (progress autorewrite with N; simpl);
    repeat match goal with
             | [ H : _ <> _ |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ = _ -> False |- _ ] => apply Nneq_out in H; nsimp H
             | [ H : _ |- _ ] => (apply (f_equal nat_of_N) in H
               || apply Nlt_out in H || apply Nge_out in H); nsimp H
           end.

Ltac nomega := pre_nomega; omega || (unfold nat_of_P in *; simpl in *; omega).


(* begin hide *)
Require Import Unicode.Utf8.
Require Import Coq.Program.Basics.
Require Import CoqCats.PolyPrelude.

Set Universe Polymorphism.
Set Polymorphic Inductive Cumulativity.
(* end hide *)

(** * Foundational representation of categories.

    I use propositional equality here in the hope that one day we will
    have quotient types/HoTT. In the mean time if we restrict
    ourselves to using quotiented versions of constructors when
    dealing with concrete categories we can pretend the non-standard
    forms don't exist.
 *)
Reserved Notation "a ⇝ b" (at level 99, b at level 200, right associativity).
Record category :=
  { object : Type;

    arrow : object → object → Type
    where "a ⇝ b" := (arrow a b);

    identity : ∀ {a}, a ⇝ a
    where "1" := identity;

    compose : ∀ {a b c}, (b ⇝ c) → (a ⇝ b) → (a ⇝ c)
    where "g ∘ f" := (compose g f);

    right_identity : ∀ {a b} {f : a ⇝ b},
        f ∘ 1 = f;
    left_identity : ∀ {a b} {f : a ⇝ b},
        1 ∘ f = f;

    compose_assoc :
      ∀ {a b c d} {f : a ⇝ b} {g : b ⇝ c} {h : c ⇝ d},
        h ∘ g ∘ f = h ∘ (g ∘ f);
  }.

Notation "g ∘ f" := (compose _ g f) : cat_scope.

Notation "1" := (identity _) : cat_scope.

Notation "a ⇝ b" := (arrow _ a b) : cat_scope.

Coercion object : category >-> Sortclass.

Delimit Scope cat_scope with cat.

Open Scope cat_scope.

Record isomorphism {cat : category} {a b : cat} (from : a ⇝ b) :=
  { to : b ⇝ a;
    comm_from : to ∘ from = 1;
    comm_to : from ∘ to = 1;
  }.

(** ** Equality properties.

    We define here some high-level properties equality gives us with
    respect to the components of a category, so that we can more
    easily switch back to an arbitrary equivalence relation in the
    future if we want to (assuming everything that operates over
    abstract categories only uses these properties rather than matching
    on the equality proof directly).
 *)
Section equality.
  Variable cat : category.
  Variable a b c : cat.
  Variable f : a ⇝ b.
  Variable g g' : b ⇝ c.
  Definition compose_transport_left (p : g = g') : g ∘ f = g' ∘ f :=
    match p with
      eq_refl => eq_refl
    end.
End equality.
Arguments compose_transport_left {cat} {a} {b} {c} {f} {g} {g'}.