Require Import Ascii.
Require Import Coq.Lists.List.

Set Universe Polymorphism.

Definition string := list ascii.

Definition env_ty := list Type.

Require Import Coq.Logic.Eqdep.
Require Import Coq.Program.Equality.
Import EqdepTheory.

Section Parsers.

  Set Universe Polymorphism.
  Variable (Vars: Set).
  Variable (Tys: Vars -> Set).

  Inductive parser: Set -> Type :=
    | pFail : forall {A: Set}, parser A
    | pEps : parser unit
    | pChar : ascii -> parser ascii
    | pAny : parser ascii
    | pCat : forall {A B: Set}, parser A -> parser B -> parser (A * B)
    | pMap : forall {A B: Set}, parser A -> (A -> B) -> parser B
    | pStar: forall {A: Set}, parser A -> parser (list A)
    | pAlt : forall {A: Set}, parser A -> parser A -> parser A
    | pVar : forall (v: Vars), parser (Tys v)
    | pBind : forall {A: Set} {F: A -> Set} (p: parser A) (f: forall a, parser (F a)),
      parser {a & F a}.

  Arguments pFail {_}.
  Arguments pCat {_ _} _ _.
  Arguments pMap {_ _} _ _.
  Arguments pStar {_} _.
  Arguments pAlt {_} _ _.
  Arguments pBind {_ _} _ _.

  Variable (Ps: forall (v: Vars), parser (Tys v)).

  Inductive Parses : string -> forall {A: Set}, parser A -> A -> Prop :=
    | Eps : Parses nil pEps tt
    | Chr : forall c, Parses (c :: nil) (pChar c) c
    | Any : forall c, Parses (c :: nil) pAny c
    | Concat :
      forall s {A B: Set} (p: parser A) v s' (p': parser B) v',
      Parses s p v ->
      Parses s' p' v' ->
      Parses (s ++ s') (pCat p p') (v, v')
    | Map:
      forall s {A B: Set} (f: A -> B) p v,
      Parses s p v ->
      Parses s (pMap p f) (f v)
    | AltL:
      forall s {A: Set} (p: parser A) p' v,
      Parses s p v ->
      Parses s (pAlt p p') v
    | AltR:
      forall s {A: Set} (p: parser A) p' v,
      Parses s p' v ->
      Parses s (pAlt p p') v
    | StarEmp:
      forall {A: Set} (p: parser A),
      Parses nil (pStar p) nil
    | StarIter:
      forall s s' {A: Set} (p: parser A) v vs,
      Parses s p v ->
      Parses s' (pStar p) vs ->
      Parses (s ++ s') (pStar p) (v :: vs)
    | Var:
      forall s var (v: Tys var),
      Parses s (Ps var) v ->
      Parses s (pVar var) v
    | Bind:
      forall s s' {A: Set} (F: A -> Set) (p: parser A) (f: forall a, parser (F a)) a b,
      Parses s p a ->
      Parses s' (f a) b ->
      Parses (s ++ s') (pBind p f) (existT _ a b).

  Ltac my_simpl :=
    repeat (unfold eq_rect in *; simpl in *; try subst;
    try match goal with
    | H: context[ match ?Eq with | eq_refl => _ end] |- _ =>
      pose (e := UIP_refl _ _ Eq);
      erewrite e in *;
      clear e
    end).

  Ltac simpl_exist H :=
    pose (e' := projT2_eq H);
    my_simpl;
    try clear e'.

  Lemma inv_map :
    forall {A B : Set} {s p} {f: A -> B} {v: B},
      Parses s (pMap p f) v ->
      exists v': A, Parses s p v' /\ f v' = v.
  Proof.
    intros.
    inversion H.
    subst.
    simpl_exist H6.
    clear H6.
    simpl_exist H4.
    clear H4.
    pose (e'' := projT2_eq H5).
    my_simpl.
    simpl_exist e''.
    clear e''.
    clear H5.
    exists v0.
    split; auto.
  Qed.

  Lemma inv_cat :
    forall {A B : Set} {s p p'} {v: A * B},
      Parses s (pCat p p') v ->
      exists s' s'' v' v'',
        Parses s' p v' /\
        Parses s'' p' v'' /\
        s = s' ++ s'' /\
        v = (v', v'').
  Proof.
    intros.
    inversion H.
    subst.
    exists s0.
    exists s'.
    exists v0.
    exists v'.
    simpl_exist H8.
    simpl_exist H6.
    simpl_exist H7.
    repeat split; auto.
  Qed.

  Lemma inv_bind :
    forall {A B: Set} {s p} {f: A -> parser B} {v},
      Parses s (pBind p f) v ->
      exists s' s'' v' v'',
        s = s' ++ s'' /\
        Parses s' p v' /\
        Parses s'' (f v') v'' /\
        v = existT _ v' v''.
    Proof.
    Admitted.

  Definition hoare_pc_parses {A: Set} (p: parser A) (Pre: string -> Prop) (Post: A -> string -> Prop) :=
    forall s v,
    Pre s ->
    Parses s p v ->
    Post v s.

  Notation "{{ Pre }} p {{ Post }}" := (hoare_pc_parses p Pre Post) (at level 80).

  Lemma hoare_chr P:
    forall c,
    {{ P c }} pChar c {{ P }}.
  Proof.
    unfold hoare_pc_parses.
    intros.
    inversion H0.
    simpl_exist H3.
    auto.
  Qed.

  Lemma hoare_eps P:
    {{ P tt }} pEps {{ P }}.
  Proof.
    unfold hoare_pc_parses.
    intros.
    inversion H0.
    simpl_exist H2.
    auto.
  Qed.

  Lemma hoare_concat {V V': Set} P P' P'' (p: parser V) (p': parser V'):
    forall v v',
    {{ P v }} p {{ P }} ->
    {{ P' v' }} p' {{ P' }} ->
    {{ P'' (v, v') }} pCat p p' {{ P'' }}.
  Admitted.

  Lemma hoare_map {A B: Set} P (p: parser A) (f: A -> B):
    forall v,
    {{ P (f v) }} pMap p f {{ P }}.
  Admitted.

  Fixpoint any {A} (ps: list (parser A)) : parser A :=
    match ps with
    | nil => pFail
    | p :: ps' => pAlt p (any ps')
    end.

  Definition pure {A: Set} (a: A) : parser A := pMap pEps (fun _ => a).

  Lemma pure_spec {A: Set}:
    forall (a: A) s v,
      Parses s (pure a) v ->
      s = nil /\ v = a.
  Proof.
    unfold pure.
    intros.
    pose proof (inv_map H).
    destruct H0 as [x [? ?]].
    subst.
    inversion H0.
    split; exact eq_refl.
  Qed.

  Fixpoint fold {A B: Set} (f: A -> B -> B) (acc: B) (ps: list (parser A)) :=
    match ps with
    | nil => pure acc
    | p :: ps' =>
      pMap (pCat p (fold f acc ps')) (fun '(a, b) => f a b)
    end.

  Definition filter {A: Set} (p: parser A) (check: A -> bool) : parser A :=
    pMap (pBind p (fun a => if check a then pure a else pFail))
      (fun x => projT2 x).

  Ltac destruct_all H :=
    try match H with
    | _ /\ _ =>
      let Hl := fresh "H" in
      let Hr := fresh "H" in
      destruct H as [Hl Hr];
      destruct_all Hl;
      destruct_all Hr
    | exists _, _ =>
      let x := fresh "x" in
      let H := fresh "H" in
      destruct H as [x H];
      destruct_all H
    end.

  Lemma filter_spec {A: Set} f:
    forall s (p: parser A) (v : A),
      Parses s (filter p f) v ->
      f v = true.
  Proof.
    intros.
    unfold filter in H.
    pose proof (inv_map H).

    destruct H0 as [? [? ?]].
    subst.
    clear H.
    pose proof (inv_bind H0).
    do 4 destruct H.
    destruct H as [? [? [? ?]]].
    subst.
    simpl.
    destruct (f x2) eqn:?.
    - pose proof inv_map H2.
      destruct H as [? [? ?]].
      subst.
      auto.
    - inversion H2.
  Qed.

  Fixpoint repeat {A} (n: nat) (p: parser A) : parser (list A) :=
    match n with
    | 0 => pure nil
    | S n' => pMap (pCat p (repeat n' p)) (fun '(x, xs) => x :: xs)
    end.

  Lemma repeat_spec {A: Set} n p:
    forall s (vs: list A),
      Parses s (repeat n p) vs ->
      length vs = n.
  Proof.
    induction n; intros; simpl.
    - unfold repeat in H.
      pose proof (pure_spec _ _ _ H).
      destruct H0.
      subst.
      exact eq_refl.
    - unfold repeat in H.
      fold (@repeat A) in H.

      pose proof inv_map H.
      destruct H0 as [? [? ?]].
      subst.

      pose proof inv_cat H0.
      destruct H1 as [? [? [? [? [? [? [?]]]]]]].

      subst.
      simpl.
      erewrite IHn; [exact eq_refl|].
      eauto.
  Qed.

  Lemma repeat_len_spec {A: Set} n:
    forall s p (v: list A) n',
      (forall s' v', Parses s' p v' -> length s' = n') ->
      Parses s (repeat n p) v ->
      length s = n * n'.
  Proof.
    intros.
    generalize H.
    induction n; intros; simpl.
    - unfold repeat in H.
      pose proof (@pure_spec (list A)).
      specialize (H2 nil s v H0).
      destruct H2.
      subst.
      exact eq_refl.
    -
      unfold repeat in H.
      fold (@repeat A) in H.
      admit.
  Admitted.

End Parsers.

Arguments parser {_ _} _.
Arguments Parses {_ _ _} _ _ _.
Arguments pFail {_ _ _}.
Arguments pEps {_ _}.
Arguments pAny {_ _}.
Arguments pChar {_ _} _.
Arguments pCat {_ _ _ _} _ _.
Arguments pMap {_ _ _ _} _ _.
Arguments pStar {_ _ _} _.
Arguments pAlt {_ _ _} _ _.
Arguments pVar {_ _} _.
Arguments pBind {_ _ _ _} _ _.

Arguments any {_ _ _} _.
Arguments pure {_ _ _} _.
Arguments filter {_ _ _} _ _.
Arguments repeat {_ _ _} _ _.
Arguments fold {_ _ _ _} _ _ _.

Infix "$" := (pCat) (at level 80).
Infix "@" := (pMap) (at level 80).
Infix "||" := (pAlt) (at level 50, left associativity).
Infix ">>=" := (pBind) (at level 80).

Notation "p1 $> p2" := (pCat p1 p2 @ fun '(_,x) => x) (at level 50).
Notation "p1 <$ p2" := (pCat p1 p2 @ fun '(x,_) => x) (at level 50).

Local Open Scope char_scope.

Definition check_prefix (ss : string * string) :=
  match fst ss with
  | nil => true
  | _ => false
  end.

Ltac obl_tac := Tactics.program_simpl.

Program Fixpoint add_prefix {s} (c: ascii) (ss: list {ss' | s = fst ss' ++ snd ss'}) : list {ss' | c :: s = fst ss' ++ snd ss'} :=
  match ss with
  | nil => nil
  | pr :: ss' =>
    let '(x, y) := pr in
      match x with
      | nil => (nil, c :: y) :: (c :: nil, y) :: add_prefix c ss'
      | _ => (c :: x, y) :: add_prefix c ss'
      end
  end.

Program Fixpoint splits (s: list ascii) : list {ss' | s = fst ss' ++ snd ss'} :=
  match s with
  | nil => (nil, nil) :: nil
  | c :: s' =>
    let ss := splits s' in
      add_prefix c ss
  end.

Ltac cat_all ss :=
  match ss with
  | ?x :: ?xs =>
    idtac "catting with:";
    idtac x;
    (cat_all xs) +
    (eapply Concat with (s := fst x) (s' := snd x))
  end.

Ltac pose_all ss :=
  match ss with
  | ?s :: ?ss' =>
    pose s; pose_all ss'
  | nil => idtac
  end.

Definition mp_ty (A: Set) := A -> list ascii -> bool.
Definition find {A: Set} (a: A) (s: list ascii) (mp: mp_ty A) := mp a s.

Scheme Equality for list.

Definition mp_empty {A: Set} : mp_ty A := fun _ _ => false.

Search (ascii -> ascii -> bool).

Definition mp_assoc {A: Set} {v_eqb: A -> A -> bool} (v: A) (s: list ascii) (mp: mp_ty A) : mp_ty A :=
  fun v' s' => if v_eqb v v' then list_beq ascii eqb s s' else find v s mp.

Ltac parse Vs Tys Ps Mp V_eqb :=
  compute;
  match goal with
  | |- Parses ?s _ ?p _ =>
    idtac "current s:";
    idtac s;
    idtac "current parser:";
    idtac p;
    idtac "current map:";
    idtac Mp
  end;
  match goal with
  | |- Parses ?s _ (_ @ _) _ => eapply (Map Vs Tys Ps _); parse Vs Tys Ps Mp V_eqb
  | |- Parses ?s _ (pChar _) _ => eapply Chr
  | |- Parses ?s _ pAny _ => eapply Any
  | |- Parses ?s _ (pVar ?v) _ =>
    assert (find v s Mp = false) by exact eq_refl;
    let Mp' := fresh "Mp" in
    pose (Mp' := mp_assoc (v_eqb := V_eqb) v s Mp);
    subst Mp;
    eapply (Var Vs Tys Ps _ v); parse Vs Tys Ps Mp' V_eqb
  | |- Parses ?s _ (?pl || ?pr) _ =>
    (eapply AltL + eapply AltR); parse Vs Tys Ps Mp V_eqb
  | |- Parses nil _ pEps _ => eapply Eps
  | |- Parses nil _ (pStar _) _ => eapply StarEmp
  | |- Parses ?s _ (_ $ _ ) _ =>
    set (tmp := (splits s));
    vm_compute in tmp;
    match goal with
    | _ := ?v |- _ =>
      pose_all v
    end;
    clear tmp;
    multimatch goal with
    | sn := ?v |- Parses ?gs _ _ _ =>
      let H := fresh "H" in
      assert (H: fst (proj1_sig sn) ++ snd (proj1_sig sn) = gs) by exact eq_refl;
      subst sn;
      simpl in H;
      erewrite <- H;
      clear H;
      eapply Concat;
      parse Vs Tys Ps Mp V_eqb
    end
  | |- Parses ?s _ (pStar _ ) _ =>
    set (tmp := (splits s));
    vm_compute in tmp;
    match goal with
    | _ := ?v |- _ =>
      pose_all v
    end;
    clear tmp;
    multimatch goal with
    | sn := ?v |- Parses ?gs _ _ _ =>
      let H := fresh "H" in
      assert (H: fst (proj1_sig sn) ++ snd (proj1_sig sn) = gs) by exact eq_refl;
      subst sn;
      simpl in H;
      erewrite <- H;
      clear H;
      eapply StarIter;
      parse Vs Tys Ps Mp V_eqb
    end
  | |- Parses ?s _ (_ >>= _ ) _ =>
    set (tmp := (splits s));
    vm_compute in tmp;
    match goal with
    | _ := ?v |- _ =>
      pose_all v
    end;
    clear tmp;
    multimatch goal with
    | sn := ?v |- Parses ?gs _ _ _ =>
      let H := fresh "H" in
      assert (H: fst (proj1_sig sn) ++ snd (proj1_sig sn) = gs) by exact eq_refl;
      subst sn;
      simpl in H;
      erewrite <- H;
      clear H;
      eapply Bind;
      parse Vs Tys Ps Mp V_eqb
    end
  end.
(*
Ltac parse_one :=
  match goal with
  | |- Parses ?s _ (_ @ _) _ => eapply Map
  | |- Parses ?s _ (pChar _) _ => eapply Chr
  | |- Parses nil _ _ pEps => eapply Eps
  end.

Ltac parse' := repeat parse_one. *)

(* a numeric parser *)
Definition dig {v env} : @parser v env nat :=
  any (
    (pChar "0" @ fun _ => 0) ::
    (pChar "1" @ fun _ => 1) ::
    (pChar "2" @ fun _ => 2) ::
    (pChar "3" @ fun _ => 3) ::
    (pChar "4" @ fun _ => 4) ::
    (pChar "5" @ fun _ => 5) ::
    (pChar "6" @ fun _ => 6) ::
    (pChar "7" @ fun _ => 7) ::
    (pChar "8" @ fun _ => 8) ::
    (pChar "9" @ fun _ => 9) ::
    nil
  ).

Definition pref_fun (x: nat * list nat) := fst x :: snd x.

Definition num {v env} := (@dig v env $ pStar dig) @ pref_fun.

Lemma length_cons:
  forall A (x: A) xs,
    length (x :: xs) = 1 + length xs.
Proof.
  intros.
  unfold length.
  fold (length xs).
  exact eq_refl.
Qed.

Require Import Coq.micromega.Lia.

Lemma pref_incr: forall x, 0 < length (pref_fun x).
Proof.
  intros.
  destruct x;
  unfold pref_fun.
  erewrite length_cons.
  Lia.lia.
Qed.

Lemma num_nonempty :
  forall V env_t env_p s v,
  @Parses V env_t env_p s _ num v -> length v > 0.
Proof.
Admitted.

Definition emp_ty (v: Empty_set) : Set := match v with end.
Definition emp_p (v: Empty_set) : @parser Empty_set emp_ty (emp_ty v) := match v with end.

Example parsing_alt : {v & @Parses Empty_set emp_ty emp_p ("1" :: nil) _ (pChar "0" || pChar "1") v}.
Proof.
  econstructor.
  parse Empty_set emp_ty emp_p tt tt.
Defined.

Definition ab_parser : @parser Empty_set emp_ty (nat * nat) :=
  ((pChar "a" @ fun _ => 1) || ((pChar "a" $ pChar "a") @ fun _ => 2))
  $
  (((pChar "b") @ fun _ => 1) || ((pChar "b" $ pChar "b") @ fun _ => 2)).

Example parsing_cat : {v & @Parses Empty_set emp_ty emp_p ("a" :: "a" :: "b" :: nil) _ ab_parser v}.
Proof.
  econstructor.
  set (v := ab_parser).
  vm_compute in v.
  subst v.

  Opaque "++".
  parse Empty_set emp_ty emp_p tt tt.
Defined.

Section NetString.
  Inductive V : Set := | ns.
  Definition Tys (v: V) : Set := list ascii.

  Fixpoint digs_2_num (digs: list nat) : nat :=
    match digs with
    | nil => 0
    | d :: ds => d + digs_2_num ds * 10
    end.

  Definition num' : @parser V Tys (nat * nat) := num @ fun ds => (digs_2_num ds, length ds).

  Definition net_string : @parser V Tys (list ascii * nat) :=
    (num' >>= fun '(n, len) =>
      (pChar ":" $ (repeat n pAny) $ pChar ",") @ (fun '(x, y, z) => (x :: y ++ z :: nil, len + n + 2)))
    @
      fun (x : {a & (list ascii * nat)%type}) => projT2 x.

  Inductive fmt :=
    | base
    | nest: list fmt -> fmt.

  Fixpoint fmt2parser (f: fmt) : @parser V Tys (list ascii * nat) :=
    match f with
    | base => net_string
    | nest fms =>
      (num' >>= fun '(n, len) =>
        let f := fun '(cs, len) '(cs', len') => (cs ++ cs', len + len') in
        let inner := fold f (nil, 0) (List.map fmt2parser fms) in
          (pChar ":" $ filter inner (fun '(_, n') => Nat.eqb n n') $ pChar ",")
          @
            fun '(x, y) => (fst x :: fst (snd x) ++ y :: nil, snd (snd x) + 1 + len))
      @
        fun (x : {a & (list ascii * nat)%type}) => projT2 x
    end.

  Definition fmt_2 := nest (base :: base :: nil).

  Definition Ps (v: V) : @parser V Tys (Tys v) := pFail.

  Definition hello :=  "5" :: ":" :: "h" :: "e" :: "l" :: "l" :: "o" :: "," :: nil.
  Definition world := "6" :: "w" :: "o" :: "r" :: "l" :: "d" :: "!" :: "," :: nil.

  Definition hello_world :=
    "1" :: "7" :: ":" :: hello ++ world ++ "," :: nil.

  Example parse_net_num: {v & @Parses V Tys Ps ("5" :: nil) _ num' v}.
  Proof.
    econstructor.
    parse V Tys Ps tt tt.
  Defined.

  Eval vm_compute in parse_net_num.

  Example parse_net_hello : {v & @Parses V Tys Ps hello _ net_string v}.
  Proof.
    econstructor.

    (* parse Vs Tys Ps tt tt. *)

    eapply Map.

    match goal with
    | |- Parses ?s _ (_ >>= _ ) _ =>
      set (tmp := (splits s));
      vm_compute in tmp;
      match goal with
      | _ := ?v |- _ =>
        pose_all v
      end;
      clear tmp

    end.

    clear s.
    clear s1.
    clear s2.
    clear s3.
    clear s4.
    clear s5.
    clear s6.
    clear s7.
    multimatch goal with
    | sn := ?v |- Parses ?gs _ _ _ =>
      let H := fresh "H" in
      assert (H: fst (proj1_sig sn) ++ snd (proj1_sig sn) = gs) by exact eq_refl;
      subst sn;
      simpl in H;
      erewrite <- H;
      eapply Bind;
      parse V Tys Ps tt tt
    end.
  Defined.

  Example parse_fmt_2 : {v & @Parses V Tys Ps hello_world _ (fmt2parser fmt_2) v}.
  Proof.
    econstructor.
    set (foo := fmt2parser fmt_2).
    compute in foo.
    subst.
    Fail parse V Tys Ps tt tt.
  Admitted.
End NetString.

Section Expr.
  Inductive ExprV : Set := | e.
  Scheme Equality for ExprV.
  Definition ExprTys (x: ExprV) : Set :=
    match x with
    | e => nat
    end.

  (* e ::= num | (e) | e + e | e * e *)

  Definition e_base : @parser ExprV ExprTys nat :=
    num @ digs_2_num.

  Definition e_parens : @parser ExprV ExprTys nat :=
    pChar "(" $> pVar e <$ pChar ")".

  Definition e_plus : @parser ExprV ExprTys nat :=
    pVar e $ (pChar "+" $> pVar e) @ fun '(x, y) => x + y.

  Definition e_times : @parser ExprV ExprTys nat :=
    pVar e $ (pChar "*" $> pVar e) @ fun '(x, y) => x * y.

  Definition expr_p : parser nat :=
    e_base || e_parens || e_plus || e_times.

  Definition ExprPs (v: ExprV) : @parser ExprV ExprTys (ExprTys v) :=
    match v with | e => expr_p end.

  Example expr_simpl : {v & @Parses ExprV ExprTys ExprPs ("4" :: "2" :: nil) _ expr_p v}.
  Proof.
    econstructor.
    pose (me := @mp_empty ExprV).
    parse ExprV ExprTys ExprPs me ExprV_beq.
  Defined.

  Example expr_var : {v & @Parses ExprV ExprTys ExprPs ("4" :: "2" :: nil) _ (pVar e) v}.
  Proof.
    econstructor.
    pose (me := @mp_empty ExprV).
    idtac "starting".
    parse ExprV ExprTys ExprPs me ExprV_beq.
  Defined.

  Example expr_parens : {v & @Parses ExprV ExprTys ExprPs ( "(" :: "3" :: ")" :: nil) _ expr_p v}.
  Proof.
    econstructor.
    pose (me := @mp_empty ExprV).

    idtac "starting".

    parse ExprV ExprTys ExprPs me ExprV_beq.
  Defined.

  Example expr_plus_times : {v & @Parses ExprV ExprTys ExprPs ( "3" :: "+" :: "4" :: "*" :: "5" :: nil) _ expr_p v}.
  Proof.
    econstructor.
    pose (me := @mp_empty ExprV).

    idtac "starting".

    parse ExprV ExprTys ExprPs me ExprV_beq.
  Defined.

End Expr.


From Coq
Require Import Recdef.
From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype seq tuple div.
From scilla
Require Import options.

Definition BITS n := n.-tuple bool.
Definition NIBBLE := BITS 4.
Definition BYTE := BITS 8.
Definition WORD := BITS 16.
Definition DWORD := BITS 32.
Definition QWORD := BITS 64.
Definition DWORDorBYTE (d: bool) :=
  BITS (if d then 32 else 8).

Function natToBits' (n : nat) (acc : seq bool) {measure id n} : seq bool :=
  if n is 0 then acc
  else let:  (q, r) := (n %/ 2, n %% 2)
       in natToBits' q (odd r :: acc).
Proof.
by move=>_ _ n _; apply/ltP; apply: ltn_Pdiv=>//.
Defined.

Definition natToBitSeq n : seq bool :=
  if n is 0 then [:: false] else natToBits' n [::].

Definition natToBits n : (size (natToBitSeq n)).-tuple bool :=
  @Tuple (size (natToBitSeq n)) _ (natToBitSeq n) (eqxx _).

Lemma bitSize {n1 n2} (b1 : BITS n1):
  n1 <= n2 -> size (nseq (n2 - n1) false ++ b1) == n2.
Proof.
by move=>N; rewrite size_cat size_tuple size_nseq subnK//.
Qed.

Function bitShift {n1 n2 : nat} (b1: BITS n1) {pf: n1 <= n2}: BITS n2
  := Tuple (bitSize b1 pf).

(* TODO: figure out how to define it with a coercion *)
Notation "# n" := (@bitShift _ _ (natToBits n) _) (at level 2).

Program Definition w : WORD  := #1232.

(* TODO: develop the theory of 256-bit signed integers *)

(* From mathcomp.algebra *)
(* Require Import ssrint. *)

(* Check a. *)

(* Function nToB n : @tuple (size natsToBits n) bool := [tuple of natToBits n]. *)

(* Check natToBits. *)

(* Eval compute in natToBits' 41 [::]. *)

(* Require Import Coq.Strings.String. *)

(* Example a : NIBBLE := [tuple of [:: false; false; true; true]]. *)

(* Fixpoint fromHex s : BITS (length s * 4) := *)
(* if s is String c s *)
(* then joinNibble (charToNibble c) (fromHex s) else 0. *)

(* Check String. *)

(* Example fortytwo := #42 : BYTE. *)

(* Definition foo (t : Type) := *)
(*   if t is option nat then True else False. *)

(* Goal option nat = nat -> False. *)
(* move=> E. *)


Require Import init.

Require Export category_base.

Require Import set.

Record morphism_to `{C0 : Category} (X : cat_U C0) := {
    morphism_to_obj : cat_U C0;
    morphism_to_f : cat_morphism C0 morphism_to_obj X;
}.

Arguments morphism_to_obj {C0} {X}.
Arguments morphism_to_f {C0} {X}.

Definition slice_set `{C0 : Category} {X : cat_U C0} (f g : morphism_to X)
    (h : cat_morphism C0 (morphism_to_obj f) (morphism_to_obj g))
    := morphism_to_f g ∘ h = morphism_to_f f.

Definition slice_set_compose `{C0 : Category} {X : cat_U C0}
    {F G H : morphism_to X}
    (f : set_type (slice_set G H)) (g : set_type (slice_set F G))
    := [f|] ∘ [g|].

Lemma slice_set_compose_in `{C0 : Category} {X : cat_U C0}
    {F G H : morphism_to X} : ∀ (f : set_type (slice_set G H)) g,
    slice_set F H (slice_set_compose f g).
Proof.
    intros [f f_eq] [g g_eq].
    unfold slice_set in *.
    unfold slice_set_compose; cbn.
    rewrite cat_assoc.
    rewrite f_eq.
    exact g_eq.
Qed.

Lemma slice_set_id_in `{C0 : Category} {X : cat_U C0}
    : ∀ f : morphism_to X, slice_set f f 𝟙.
Proof.
    intros f.
    unfold slice_set.
    apply cat_rid.
Qed.

(* begin show *)
Local Program Instance SLICE `(C0 : Category) (X : cat_U C0) : Category := {
    cat_U := morphism_to X;
    cat_morphism f g := set_type (slice_set f g);
    cat_compose {F G H} f g := [_|slice_set_compose_in f g];
    cat_id f := [_|slice_set_id_in f];
}.
(* end show *)
Next Obligation.
    apply set_type_eq; cbn.
    unfold slice_set_compose; cbn.
    apply cat_assoc.
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    unfold slice_set_compose; cbn.
    apply cat_lid.
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    unfold slice_set_compose; cbn.
    apply cat_rid.
Qed.

Record morphism_from `{C0 : Category} (X : cat_U C0) := {
    morphism_from_obj : cat_U C0;
    morphism_from_f : cat_morphism C0 X morphism_from_obj;
}.

Arguments morphism_from_obj {C0} {X}.
Arguments morphism_from_f {C0} {X}.

Definition coslice_set `{C0 : Category} {X : cat_U C0} (f g : morphism_from X)
    (h : cat_morphism C0 (morphism_from_obj f) (morphism_from_obj g))
    := h ∘ morphism_from_f f = morphism_from_f g.

Definition coslice_set_compose `{C0 : Category} {X : cat_U C0}
    {F G H : morphism_from X}
    (f : set_type (coslice_set G H)) (g : set_type (coslice_set F G))
    := [f|] ∘ [g|].

Lemma coslice_set_compose_in `{C0 : Category} {X : cat_U C0}
    {F G H : morphism_from X} : ∀ (f : set_type (coslice_set G H)) g,
    coslice_set F H (coslice_set_compose f g).
Proof.
    intros [f f_eq] [g g_eq].
    unfold coslice_set in *.
    unfold coslice_set_compose; cbn.
    rewrite <- cat_assoc.
    rewrite g_eq.
    exact f_eq.
Qed.

Lemma coslice_set_id_in `{C0 : Category} {X : cat_U C0}
    : ∀ f : morphism_from X, coslice_set f f 𝟙.
Proof.
    intros f.
    unfold coslice_set.
    apply cat_lid.
Qed.

Local Program Instance COSLICE `(C0 : Category) (X : cat_U C0) : Category := {
    cat_U := morphism_from X;
    cat_morphism f g := set_type (coslice_set f g);
    cat_compose {F G H} f g := [_|coslice_set_compose_in f g];
    cat_id f := [_|coslice_set_id_in f];
}.
Next Obligation.
    apply set_type_eq; cbn.
    unfold coslice_set_compose; cbn.
    apply cat_assoc.
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    unfold coslice_set_compose; cbn.
    apply cat_lid.
Qed.
Next Obligation.
    apply set_type_eq; cbn.
    unfold slice_set_compose; cbn.
    apply cat_rid.
Qed.


From ExtLib Require Import
     Functor.

Set Implicit Arguments.
Set Maximal Implicit Insertion.
Set Universe Polymorphism.

Class Applicative@{d c} (T : Type@{d} -> Type@{c}) :=
{ pure : forall {A : Type@{d}}, A -> T A
; ap : forall {A B : Type@{d}}, T (A -> B) -> T A -> T B
}.

Module ApplicativeNotation.
  Notation "f <*> x" := (ap f x) (at level 52, left associativity).
End ApplicativeNotation.
Import ApplicativeNotation.

Section applicative.
  Definition liftA@{d c} {T : Type@{d} -> Type@{c}} {AT:Applicative@{d c} T} {A B : Type@{d}} (f:A -> B) (aT:T A) : T B := pure f <*> aT.
  Definition liftA2@{d c} {T : Type@{d} -> Type@{c}} {AT:Applicative@{d c} T} {A B C : Type@{d}} (f:A -> B -> C) (aT:T A) (bT:T B) : T C := liftA f aT <*> bT.
End applicative.

Section Instances.

Universe d c.
Context (T : Type@{d} -> Type@{c}) {AT : Applicative T}.

Global Instance Functor_Applicative@{} : Functor T :=
{ fmap := @liftA _ _ }.

End Instances.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__ABCequalsCBA.
Require Export lemma__angleorderrespectscongruence.
Require Export lemma__angleorderrespectscongruence2.
Require Export lemma__angleordertransitive.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__equalangleshelper.
Require Export lemma__equalanglesreflexive.
Require Export lemma__equalanglessymmetric.
Require Export lemma__inequalitysymmetric.
Require Export lemma__ray4.
Require Export logic.
Require Export proposition__05.
Require Export proposition__16.
Definition proposition__18 : forall A B C, (euclidean__axioms.Triangle A B C) -> ((euclidean__defs.Lt A B A C) -> (euclidean__defs.LtA B C A A B C)).
Proof.
intro A.
intro B.
intro C.
intro H.
intro H0.
assert (euclidean__axioms.nCol A B C) as H1 by exact H.
assert (* Cut *) (~(A = B)) as H2.
- intro H2.
assert (* Cut *) (euclidean__axioms.Col A B C) as H3.
-- left.
exact H2.
-- apply (@euclidean__tactics.Col__nCol__False A B C H1 H3).
- assert (* Cut *) (euclidean__axioms.neq B A) as H3.
-- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A B H2).
-- assert (* Cut *) (~(A = C)) as H4.
--- intro H4.
assert (* Cut *) (euclidean__axioms.Col A B C) as H5.
---- right.
left.
exact H4.
---- apply (@euclidean__tactics.Col__nCol__False A B C H1 H5).
--- assert (* Cut *) (euclidean__axioms.neq C A) as H5.
---- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A C H4).
---- assert (* Cut *) (euclidean__axioms.Cong A C A C) as H6.
----- apply (@euclidean__axioms.cn__congruencereflexive A C).
----- assert (exists D, (euclidean__axioms.BetS A D C) /\ (euclidean__axioms.Cong A D A B)) as H7 by exact H0.
destruct H7 as [D H8].
destruct H8 as [H9 H10].
assert (* Cut *) (~(euclidean__axioms.Col B C D)) as H11.
------ intro H11.
assert (* Cut *) (euclidean__axioms.Col D C B) as H12.
------- assert (* Cut *) ((euclidean__axioms.Col C B D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D B C) /\ ((euclidean__axioms.Col B D C) /\ (euclidean__axioms.Col D C B))))) as H12.
-------- apply (@lemma__collinearorder.lemma__collinearorder B C D H11).
-------- destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
exact H20.
------- assert (* Cut *) (euclidean__axioms.Col A D C) as H13.
-------- right.
right.
right.
right.
left.
exact H9.
-------- assert (* Cut *) (euclidean__axioms.Col D C A) as H14.
--------- assert (* Cut *) ((euclidean__axioms.Col D A C) /\ ((euclidean__axioms.Col D C A) /\ ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col A C D) /\ (euclidean__axioms.Col C D A))))) as H14.
---------- apply (@lemma__collinearorder.lemma__collinearorder A D C H13).
---------- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H17.
--------- assert (* Cut *) (euclidean__axioms.neq D C) as H15.
---------- assert (* Cut *) ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq A D) /\ (euclidean__axioms.neq A C))) as H15.
----------- apply (@lemma__betweennotequal.lemma__betweennotequal A D C H9).
----------- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H16.
---------- assert (* Cut *) (euclidean__axioms.Col C B A) as H16.
----------- apply (@euclidean__tactics.not__nCol__Col C B A).
------------intro H16.
apply (@euclidean__tactics.Col__nCol__False C B A H16).
-------------apply (@lemma__collinear4.lemma__collinear4 D C B A H12 H14 H15).

----------- assert (* Cut *) (euclidean__axioms.Col A B C) as H17.
------------ assert (* Cut *) ((euclidean__axioms.Col B C A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A C B) /\ ((euclidean__axioms.Col C A B) /\ (euclidean__axioms.Col A B C))))) as H17.
------------- apply (@lemma__collinearorder.lemma__collinearorder C B A H16).
------------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H25.
------------ apply (@euclidean__tactics.Col__nCol__False A B C H1 H17).
------ assert (* Cut *) (euclidean__axioms.Triangle B C D) as H12.
------- apply (@euclidean__tactics.nCol__notCol B C D H11).
------- assert (* Cut *) (euclidean__axioms.BetS C D A) as H13.
-------- apply (@euclidean__axioms.axiom__betweennesssymmetry A D C H9).
-------- assert (* Cut *) (euclidean__defs.LtA D C B B D A) as H14.
--------- assert (* Cut *) (forall A0 B0 C0 D0, (euclidean__axioms.Triangle A0 B0 C0) -> ((euclidean__axioms.BetS B0 C0 D0) -> (euclidean__defs.LtA C0 B0 A0 A0 C0 D0))) as H14.
---------- intro A0.
intro B0.
intro C0.
intro D0.
intro __.
intro __0.
assert (* AndElim *) ((euclidean__defs.LtA B0 A0 C0 A0 C0 D0) /\ (euclidean__defs.LtA C0 B0 A0 A0 C0 D0)) as __1.
----------- apply (@proposition__16.proposition__16 A0 B0 C0 D0 __ __0).
----------- destruct __1 as [__1 __2].
exact __2.
---------- apply (@H14 B C D A H12 H13).
--------- assert (* Cut *) (~(B = C)) as H15.
---------- intro H15.
assert (* Cut *) (euclidean__axioms.Col B C D) as H16.
----------- left.
exact H15.
----------- apply (@H11 H16).
---------- assert (* Cut *) (euclidean__axioms.neq C B) as H16.
----------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H15).
----------- assert (* Cut *) (~(euclidean__axioms.Col A D B)) as H17.
------------ intro H17.
assert (* Cut *) (euclidean__axioms.Col A D C) as H18.
------------- right.
right.
right.
right.
left.
exact H9.
------------- assert (* Cut *) (euclidean__axioms.Col D A C) as H19.
-------------- assert (* Cut *) ((euclidean__axioms.Col D A C) /\ ((euclidean__axioms.Col D C A) /\ ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col A C D) /\ (euclidean__axioms.Col C D A))))) as H19.
--------------- apply (@lemma__collinearorder.lemma__collinearorder A D C H18).
--------------- destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
destruct H25 as [H26 H27].
exact H20.
-------------- assert (* Cut *) (euclidean__axioms.Col D A B) as H20.
--------------- assert (* Cut *) ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col D B A) /\ ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col A B D) /\ (euclidean__axioms.Col B D A))))) as H20.
---------------- apply (@lemma__collinearorder.lemma__collinearorder A D B H17).
---------------- destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
exact H21.
--------------- assert (* Cut *) (euclidean__axioms.neq A D) as H21.
---------------- assert (* Cut *) ((euclidean__axioms.neq D C) /\ ((euclidean__axioms.neq A D) /\ (euclidean__axioms.neq A C))) as H21.
----------------- apply (@lemma__betweennotequal.lemma__betweennotequal A D C H9).
----------------- destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H24.
---------------- assert (* Cut *) (euclidean__axioms.neq D A) as H22.
----------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric A D H21).
----------------- assert (* Cut *) (euclidean__axioms.Col A C B) as H23.
------------------ apply (@euclidean__tactics.not__nCol__Col A C B).
-------------------intro H23.
apply (@euclidean__tactics.Col__nCol__False A C B H23).
--------------------apply (@lemma__collinear4.lemma__collinear4 D A C B H19 H20 H22).

------------------ assert (* Cut *) (euclidean__axioms.Col A B C) as H24.
------------------- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H24.
-------------------- apply (@lemma__collinearorder.lemma__collinearorder A C B H23).
-------------------- destruct H24 as [H25 H26].
destruct H26 as [H27 H28].
destruct H28 as [H29 H30].
destruct H30 as [H31 H32].
exact H31.
------------------- apply (@H11).
--------------------apply (@euclidean__tactics.not__nCol__Col B C D).
---------------------intro H25.
apply (@euclidean__tactics.Col__nCol__False A B C H1 H24).

------------ assert (* Cut *) (euclidean__axioms.Triangle A D B) as H18.
------------- apply (@euclidean__tactics.nCol__notCol A D B H17).
------------- assert (* Cut *) (euclidean__defs.isosceles A D B) as H19.
-------------- split.
--------------- exact H18.
--------------- exact H10.
-------------- assert (* Cut *) (euclidean__defs.CongA A D B A B D) as H20.
--------------- apply (@proposition__05.proposition__05 A D B H19).
--------------- assert (* Cut *) (euclidean__defs.Out C A D) as H21.
---------------- apply (@lemma__ray4.lemma__ray4 C A D).
-----------------left.
exact H13.

----------------- exact H5.
---------------- assert (* Cut *) (B = B) as H22.
----------------- apply (@logic.eq__refl Point B).
----------------- assert (* Cut *) (euclidean__defs.Out C B B) as H23.
------------------ apply (@lemma__ray4.lemma__ray4 C B B).
-------------------right.
left.
exact H22.

------------------- exact H16.
------------------ assert (* Cut *) (~(euclidean__axioms.Col A C B)) as H24.
------------------- intro H24.
assert (* Cut *) (euclidean__axioms.Col A B C) as H25.
-------------------- assert (* Cut *) ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col B A C) /\ ((euclidean__axioms.Col A B C) /\ (euclidean__axioms.Col B C A))))) as H25.
--------------------- apply (@lemma__collinearorder.lemma__collinearorder A C B H24).
--------------------- destruct H25 as [H26 H27].
destruct H27 as [H28 H29].
destruct H29 as [H30 H31].
destruct H31 as [H32 H33].
exact H32.
-------------------- apply (@H11).
---------------------apply (@euclidean__tactics.not__nCol__Col B C D).
----------------------intro H26.
apply (@euclidean__tactics.Col__nCol__False A B C H1 H25).

------------------- assert (* Cut *) (euclidean__defs.CongA A C B A C B) as H25.
-------------------- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive A C B).
---------------------apply (@euclidean__tactics.nCol__notCol A C B H24).

-------------------- assert (* Cut *) (euclidean__defs.CongA A C B D C B) as H26.
--------------------- apply (@lemma__equalangleshelper.lemma__equalangleshelper A C B A C B D B H25 H21 H23).
--------------------- assert (* Cut *) (euclidean__defs.LtA A C B B D A) as H27.
---------------------- apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 D C B B D A A C B H14 H26).
---------------------- assert (* Cut *) (euclidean__defs.CongA A D B B D A) as H28.
----------------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA A D B H18).
----------------------- assert (* Cut *) (euclidean__defs.LtA A C B A D B) as H29.
------------------------ apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence A C B B D A A D B H27 H28).
------------------------ assert (* Cut *) (euclidean__defs.CongA A B D A D B) as H30.
------------------------- apply (@lemma__equalanglessymmetric.lemma__equalanglessymmetric A D B A B D H20).
------------------------- assert (* Cut *) (euclidean__defs.LtA A C B A B D) as H31.
-------------------------- apply (@lemma__angleorderrespectscongruence.lemma__angleorderrespectscongruence A C B A D B A B D H29 H30).
-------------------------- assert (* Cut *) (~(euclidean__axioms.Col B C A)) as H32.
--------------------------- intro H32.
assert (* Cut *) (euclidean__axioms.Col A B C) as H33.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col C B A) /\ ((euclidean__axioms.Col C A B) /\ ((euclidean__axioms.Col A B C) /\ ((euclidean__axioms.Col B A C) /\ (euclidean__axioms.Col A C B))))) as H33.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C A H32).
----------------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H38.
---------------------------- apply (@H11).
-----------------------------apply (@euclidean__tactics.not__nCol__Col B C D).
------------------------------intro H34.
apply (@euclidean__tactics.Col__nCol__False A B C H1 H33).

--------------------------- assert (* Cut *) (euclidean__defs.CongA B C A A C B) as H33.
---------------------------- apply (@lemma__ABCequalsCBA.lemma__ABCequalsCBA B C A).
-----------------------------apply (@euclidean__tactics.nCol__notCol B C A H32).

---------------------------- assert (* Cut *) (euclidean__defs.LtA B C A A B D) as H34.
----------------------------- apply (@lemma__angleorderrespectscongruence2.lemma__angleorderrespectscongruence2 A C B A B D B C A H31 H33).
----------------------------- assert (* Cut *) (C = C) as H35.
------------------------------ apply (@logic.eq__refl Point C).
------------------------------ assert (* Cut *) (A = A) as H36.
------------------------------- apply (@logic.eq__refl Point A).
------------------------------- assert (* Cut *) (euclidean__defs.Out B C C) as H37.
-------------------------------- apply (@lemma__ray4.lemma__ray4 B C C).
---------------------------------right.
left.
exact H35.

--------------------------------- exact H15.
-------------------------------- assert (* Cut *) (euclidean__defs.Out B A A) as H38.
--------------------------------- apply (@lemma__ray4.lemma__ray4 B A A).
----------------------------------right.
left.
exact H36.

---------------------------------- exact H3.
--------------------------------- assert (* Cut *) (~(euclidean__axioms.Col A B D)) as H39.
---------------------------------- intro H39.
assert (* Cut *) (euclidean__axioms.Col A D B) as H40.
----------------------------------- assert (* Cut *) ((euclidean__axioms.Col B A D) /\ ((euclidean__axioms.Col B D A) /\ ((euclidean__axioms.Col D A B) /\ ((euclidean__axioms.Col A D B) /\ (euclidean__axioms.Col D B A))))) as H40.
------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder A B D H39).
------------------------------------ destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
exact H47.
----------------------------------- apply (@H11).
------------------------------------apply (@euclidean__tactics.not__nCol__Col B C D).
-------------------------------------intro H41.
apply (@H17 H40).

---------------------------------- assert (* Cut *) (euclidean__defs.CongA A B D A B D) as H40.
----------------------------------- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive A B D).
------------------------------------apply (@euclidean__tactics.nCol__notCol A B D H39).

----------------------------------- assert (* Cut *) (euclidean__defs.LtA A B D A B C) as H41.
------------------------------------ exists A.
exists D.
exists C.
split.
------------------------------------- exact H9.
------------------------------------- split.
-------------------------------------- exact H38.
-------------------------------------- split.
--------------------------------------- exact H37.
--------------------------------------- exact H40.
------------------------------------ assert (* Cut *) (euclidean__defs.LtA B C A A B C) as H42.
------------------------------------- apply (@lemma__angleordertransitive.lemma__angleordertransitive B C A A B D A B C H34 H41).
------------------------------------- exact H42.
Qed.


(***********************************************************************)
(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
(*                                                                     *)
(***********************************************************************)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat.
Require Import div seq fintype.
(* Require Import connect. *)
Require Import tuple finfun ssralg bigops finset.
Require Import groups group_perm morphisms action maximal.

(* n-transitive and primitive actions *)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Import GroupScope.

Section PrimitiveDef.

Variables (aT : finGroupType) (sT : finType).
Variables (A : {set aT}) (to : {action aT &-> sT}) (S : {set sT}).

Definition imprimitivity_system Q :=
  [&& partition Q S, [acts (A | to^*) on Q] & 1 < #|Q| < #|S|].

Definition primitive :=
  [transitive (A | to) on S] && ~~ existsb Q, imprimitivity_system Q.

End PrimitiveDef.

Notation "[ 'primitive' ( A | to ) 'on' S ]" := (primitive A to S)
  (at level 0, format "[ 'primitive'  (  A  |  to  )  'on'  S ]") : form_scope.

Prenex Implicits imprimitivity_system.

Section Primitive.

Variables (aT : finGroupType) (sT : finType).
Variables (G : {group aT}) (to : {action aT &-> sT}) (S : {set sT}).

Lemma trans_prim_astab : forall x,
  x \in S -> [transitive (G | to) on S] ->
    [primitive (G | to) on S] = maximal_eq 'C_(G | to)[x] G.
Proof.
move=> x Sx trG; rewrite /primitive trG negb_exists.
apply/forallP/maximal_eqP=> /= [primG | [_ maxCx] Q].
  split=> [|H sCH sHG]; first exact: subsetIl.
  pose X := orbit to H x; pose Q := orbit (to^*)%act G X.
  have Xx: x \in X by exact: orbit_refl.
  have defH: 'N_(G | to)(X) = H.
    have trH: [transitive (H | to) on X] by apply/imsetP; exists x.
    have sHN: H \subset 'N_(G | to)(X) by rewrite subsetI sHG trans_acts.
    move/(subgroup_transitiveP Xx sHN): (trH) => /= <-.
      by rewrite mulSGid //= setIAC subIset ?sCH.
    apply/imsetP; exists x => //; apply/eqP.
    by rewrite eqEsubset imsetS // acts_orbit ?subsetIr.
  move: (sCH); rewrite subEproper; case/predU1P; first by left.
  move/proper_card=> oCH; right; apply/eqP; rewrite eqEcard sHG leqNgt.
  apply: contra {primG}(primG Q) => oHG; apply/and3P; split; last first.
  - rewrite card_orbit astab1_set defH -(@ltn_pmul2l #|H|) ?LaGrange // muln1.
    rewrite oHG -(@ltn_pmul2l #|H|) ?LaGrange // -(card_orbit_stab to G x).
    by rewrite -(atransP trG x Sx) mulnC card_orbit ltn_pmul2r.
  - by apply/actsP=> a Ga Y; apply: orbit_transr; exact: orbit_to.
  apply/and3P; split; last 1 first.
  - rewrite orbit_sym; apply/imsetP=> [[a _]] /= defX.
    by rewrite defX /set_act imset0 inE in Xx.
  - apply/eqP; apply/setP=> y; apply/bigcupP/idP=> [[Xa] | Sy].
      case/imsetP=> a Ga ->{Xa}; case/imsetP=> z; case/imsetP=> b Hb -> ->.
      by rewrite !(actsP (trans_acts trG)) //; exact: subsetP Hb.
    case: (atransP2 trG Sx Sy) => a Ga ->.
    by exists ((to^*)%act X a); apply: mem_imset; rewrite // orbit_refl.
  apply/trivIsetP=> Y Z; case/imsetP=> a Ga ->; case/imsetP=> b Gb ->{Y Z}.
  case dab: [disjoint _ & _]; [by right | left].
  apply: (canRL (actKV _ _)); rewrite -actM; apply/astab1P.
  rewrite astab1_set (subsetP (subsetIr G _)) //= defH.
  case/existsP: dab => y; case/andP.
  case/imsetP=> z; case/imsetP=> a1 Ha1 -> ->{y z}.
  case/imsetP=> t; case/imsetP=> b1 Hb1 ->{t}.
  do 2!move/(canLR (actK _ _)); rewrite -!actM; move/astab1P => Cab.
  rewrite -(groupMr _ (groupVr Hb1)) -mulgA -(groupMl _ Ha1).
  by rewrite (subsetP sCH) // inE Cab !groupM ?groupV // (subsetP sHG).
apply/and3P=> [[]]; case/and3P; set sto := (to^*)%act.
move/eqP=> defS tIQ ntQ actQ; rewrite !ltnNge -negb_or; case/orP.
pose X := cover_at x Q; have Xx: x \in X by rewrite mem_cover_at defS.
have QX: X \in Q by rewrite cover_at_mem ?defS.
have toX: forall Y a, Y \in Q -> a \in G -> to x a \in Y -> sto X a = Y.
  move=> Y a QY Ga Yxa; case: (trivIsetP tIQ Y (sto X a)) => //.
    by rewrite (actsP actQ).
  by case/existsP; exists (to x a); rewrite /= Yxa; exact: mem_imset.
have defQ: Q = orbit (to^*)%act G X.
  apply/eqP; rewrite eqEsubset andbC acts_orbit // QX.
  apply/subsetP=> Y QY; have:= sub0set Y; rewrite subEproper.
  case/predU1P=> [Y0|]; first by rewrite Y0 QY in ntQ.
  case/andP=> _; case/subsetPn=> y Yy _.
  have Sy: y \in S by rewrite -defS; apply/bigcupP; exists Y.
  have [a Ga def_y] := atransP2 trG Sx Sy.
  by apply/imsetP; exists a; rewrite // (toX Y) // -def_y.
rewrite defQ card_orbit; case: (maxCx 'C_(G | sto)[X]%G) => /= [||->|->].
- apply/subsetP=> a; case/setIP=> Ga cxa; rewrite inE Ga /=.
  by apply/astab1P; rewrite (toX X) // (astab1P cxa).
- exact: subsetIl.
- by right; rewrite -card_orbit (atransP trG).
by left; rewrite indexgg.
Qed.

Lemma prim_trans_norm : forall H : {group aT},
  [primitive (G | to) on S] -> H <| G ->
     H \subset 'C_(G | to)(S) \/ [transitive (H | to) on S].
Proof.
move=> H primG; case/andP=> sHG nHG; rewrite subsetI sHG.
have [trG _] := andP primG; have [x Sx defS] := imsetP trG.
move: primG; rewrite (trans_prim_astab Sx) //; case/maximal_eqP=> _.
case/(_ ('C_(G | to)[x] <*> H)%G) => /= [||cxH|]; first exact: mulgen_subl.
- by rewrite mulgen_subG subsetIl.
- have{cxH} cxH: H \subset 'C_(G | to)[x] by rewrite -cxH mulgen_subr.
  rewrite subsetI sHG /= in cxH; left; apply/subsetP=> a Ha.
  apply/astabP=> y Sy; have [b Gb ->] := atransP2 trG Sx Sy.
  rewrite actCJV [to x (a ^ _)](astab1P _) ?(subsetP cxH) //.
  by rewrite -mem_conjg (normsP nHG).
rewrite norm_mulgenEl ?subIset ?nHG //.
by move/(subgroup_transitiveP Sx sHG trG); right.
Qed.

End Primitive.

Section NactionDef.

Variables (gT : finGroupType) (sT : finType).

Variable to : {action gT &-> sT}.
Variable n :  nat.

Definition n_act (t : n.-tuple sT) a := [tuple of maps (to^~ a) t].

Lemma n_act_is_action : is_action n_act.
Proof.
by split=> [t|t a b]; apply: eq_from_tsub=> i; rewrite !tsub_maps ?act1 ?actM.
Qed.

Canonical Structure n_act_action := Action n_act_is_action.

End NactionDef.

Notation "to * n" := (n_act_action to n) : action_scope.

Section NTransitive.

Variables (gT : finGroupType) (sT : finType).
Variable n :  nat.
Variable A : {set gT}.
Variable to : {action gT &-> sT}.
Variable S : {set sT}.

Definition dtuple_on := [set t : n.-tuple sT | uniq t && (t \subset S)].
Definition ntransitive := [transitive (A | to * n) on dtuple_on].

Lemma dtuple_onP : forall t,
  reflect (injective (tsub t) /\ forall i, tsub t i \in S) (t \in dtuple_on).
Proof.
move=> t; rewrite inE subset_all -maps_tsub_enum.
case: (uniq _) / (injectiveP (tsub t)) => f_inj; last by right; case.
rewrite -[all _ _]negbK -has_predC has_maps has_predC negbK /=.
by apply: (iffP allP) => [Sf|[]//]; split=> // i; rewrite Sf ?mem_enum.
Qed.

Lemma n_act_dtuple : forall t a,
  a \in 'N_(|to)(S) -> t \in dtuple_on -> n_act to t a \in dtuple_on.
Proof.
move=> t a; move/astabsP=> toSa; case/dtuple_onP=> t_inj St; apply/dtuple_onP.
split=> [i j | i]; rewrite !tsub_maps ?[_ \in S]toSa //.
by move/act_inj; exact: t_inj.
Qed.

End NTransitive.

Implicit Arguments n_act [gT sT n].

Notation "n .-dtuple ( S )" := (dtuple_on n S)
  (at level 8, format "n .-dtuple ( S )") : set_scope.

Notation "[ 'transitive' * n ( A | to ) 'on' S ]" := (ntransitive n A to S)
  (at level 0, n at level 8,
   format "[ 'transitive'  *  n  ( A  |  to )  'on'  S ]") : form_scope.

Section NTransitveProp.

Variable (gT : finGroupType) (sT : finType).
Variable to : {action gT &-> sT}.
Variable G : {group gT}.
Variable S : {set sT}.

Lemma card_uniq_tuple n (t : n.-tuple sT) : uniq t -> #|t| = n.
Proof. move=> n t; move/card_uniqP->; exact: size_tuple. Qed.

Lemma n_act0 (t : 0.-tuple sT) a : n_act to t a = [tuple].
Proof. move=> *; exact: tuple0. Qed.

Lemma dtuple_on_add : forall n x (t : n.-tuple sT),
  ([tuple of x :: t] \in n.+1.-dtuple(S)) =
     [&& x \in S, x \notin t & t \in n.-dtuple(S)].
Proof. move=> *; rewrite !inE memtE !subset_all -!andbA; do !bool_congr. Qed.

Lemma dtuple_on_add_D1 : forall n x (t : n.-tuple sT),
  ([tuple of x :: t] \in n.+1.-dtuple(S))
     = (x \in S) && (t \in n.-dtuple(S :\ x)).
Proof.
move=> n x t; rewrite dtuple_on_add !inE (andbCA (~~ _)); do 2!congr (_ && _).
rewrite -!(eq_subset (in_set (mem t))) setDE setIC subsetI; congr (_ && _).
by rewrite -setCS setCK sub1set !inE.
Qed.

Lemma dtuple_on_subset : forall n (S1 S2 : {set sT}) t,
  S1 \subset S2 -> t \in n.-dtuple(S1) -> t \in n.-dtuple(S2).
Proof.
move=> n S1 S2 t sS12; rewrite !inE; case/andP=> ->; move/subset_trans; exact.
Qed.

Lemma n_act_add n x (t : n.-tuple sT) a :
  n_act to [tuple of x :: t] a = [tuple of to x a :: n_act to t a].
Proof. by move=> *; exact: val_inj. Qed.

Lemma ntransitive0 : [transitive * 0 (G | to) on S].
Proof.
have dt0: [tuple] \in 0.-dtuple(S) by rewrite inE memtE subset_all.
apply/imsetP; exists [tuple of Seq0 sT] => //.
by apply/setP=> x; rewrite [x]tuple0 orbit_refl.
Qed.

Lemma ntransitive_weak : forall k m,
  k <= m -> [transitive * m (G | to) on S] -> [transitive * k (G | to) on S].
Proof.
move=> k m; move/subnK <-; rewrite addnC; elim: {m}(m - k) => // m IHm.
rewrite addSn => tr_m1; apply: IHm; move: {m k}(m + k) tr_m1 => m tr_m1.
have ext_t: forall t, t \in dtuple_on m S ->
  exists x, [tuple of x :: t] \in m.+1.-dtuple(S).
- move=> /= t dt; case sSt: (S \subset t); last first.
    case/subsetPn: sSt => x Sx ntx.
    by exists x; rewrite dtuple_on_add andbA /= Sx ntx.
  case/imsetP: tr_m1 dt => t1.
  rewrite !inE; case/andP=> Ut1 St1 _; case/andP=> Ut _.
  have:= subset_trans St1 sSt; move/subset_leq_card.
  by rewrite !card_uniq_tuple // ltnn.
case/imsetP: (tr_m1); case/tupleP=> x t; rewrite dtuple_on_add.
case/and3P=> Sx ntx dt; set xt := [tuple of _] => tr_xt.
apply/imsetP; exists t => //.
apply/setP=> u; apply/idP/imsetP=> [du | [a Ga ->{u}]].
  case: (ext_t u du) => y; rewrite tr_xt.
  by case/imsetP=> a Ga [_ def_u]; exists a => //; exact: val_inj.
have: n_act to xt a \in dtuple_on _ S by rewrite tr_xt mem_imset.
by rewrite n_act_add dtuple_on_add; case/and3P.
Qed.

Lemma ntransitive1 : forall m,
  0 < m -> [transitive * m (G | to) on S] -> [transitive (G | to) on S].
Proof.
have trdom1: forall x, ([tuple x] \in 1.-dtuple(S)) = (x \in S).
  by move=> x; rewrite dtuple_on_add !inE memtE subset_all andbT.
move=> m m_pos; move/(ntransitive_weak m_pos)=> {m m_pos}.
case/imsetP; case/tupleP=> x t0; rewrite {t0}(tuple0 t0) trdom1 => Sx trx.
apply/imsetP; exists x => //; apply/setP=> y; rewrite -trdom1 trx.
apply/imsetP/imsetP; case=> a Ga [->]; exists a => //; exact: val_inj.
Qed.

Lemma ntransitive_primitive : forall m,
  1 < m -> [transitive * m (G | to) on S] -> [primitive (G | to) on S].
Proof.
move=> m lt1m; move/(ntransitive_weak lt1m) => {m lt1m} tr2G.
have trG: [transitive (G | to) on S] by exact: ntransitive1 tr2G.
have [x Sx _]:= imsetP trG; rewrite (trans_prim_astab Sx trG).
apply/maximal_eqP; split=> [|H]; first exact: subsetIl; rewrite subEproper.
case/predU1P; first by [left]; case/andP=> sCH; case/subsetPn=> a Ha nCa sHG.
right; rewrite -(subgroup_transitiveP Sx sHG trG _) ?mulSGid //.
have actH := subset_trans sHG (trans_acts trG).
pose y := to x a; have Sy: y \in S by rewrite (actsP actH).
have{nCa} yx: y != x by rewrite inE (sameP astab1P eqP) (subsetP sHG) in nCa.
apply/imsetP; exists y => //; apply/eqP.
rewrite eqEsubset acts_orbit // Sy andbT; apply/subsetP=> z Sz.
case: (z =P x) => [->|]; last move/eqP=> zx.
  by rewrite orbit_sym orbit_to.
pose ty := [tuple y; x]; pose tz := [tuple z; x].
have [Sty Stz]: ty \in 2.-dtuple(S) /\ tz \in 2.-dtuple(S).
  rewrite !inE !memtE !subset_all /= !mem_seq1 !andbT; split; exact/and3P.
case: (atransP2 tr2G Sty Stz) => b Gb [->]; move/esym; move/astab1P=> cxb.
by rewrite orbit_to // (subsetP sCH) // inE Gb.
Qed.

End NTransitveProp.

Section NTransitveProp1.

Variable (gT : finGroupType) (sT : finType).

Variable to : {action gT &-> sT}.
Variable G : {group gT}.
Variable S : {set sT}.

(* Corresponds to => of 15.12.1 Aschbacher *)
Theorem stab_ntransitive : forall m x,
     0 < m -> x \in S ->  [transitive * m.+1 (G | to) on S]
  -> [transitive * m ('C_(G | to)[x] | to) on S :\ x].
Proof.
move=> m x m_pos Sx Gtr; have sSxS: S :\ x \subset S by rewrite subsetDl.
case: (imsetP Gtr); case/tupleP=> x1 t1; rewrite dtuple_on_add.
case/and3P=> Sx1 nt1x1 dt1 trt1; have Gtr1 := ntransitive1 (ltn0Sn _) Gtr.
case: (atransP2 Gtr1 Sx1 Sx) => // a Ga x1ax.
pose t := n_act to t1 a.
have dxt: [tuple of x :: t] \in m.+1.-dtuple(S).
  rewrite trt1 x1ax; apply/imsetP; exists a => //; exact: val_inj.
apply/imsetP; exists t.
  by rewrite dtuple_on_add_D1 Sx in dxt.
apply/setP=> t2; apply/idP/imsetP => [dt2|[b]].
  have: [tuple of x :: t2] \in dtuple_on _ S by rewrite dtuple_on_add_D1 Sx.
  case/(atransP2 Gtr dxt)=> b Gb [xbx tbt2].
  exists b; [rewrite inE Gb; exact/astab1P | exact: val_inj].
case/setIP=> Gb; move/astab1P=> xbx ->{t2}.
rewrite n_act_dtuple //; last by rewrite dtuple_on_add_D1 Sx in dxt.
apply/astabsP=> y; rewrite !inE -{1}xbx (inj_eq (act_inj _ _)).
by rewrite (actsP (trans_acts Gtr1)).
Qed.

(* Correspond to <= of 15.12.1 Aschbacher *)
Theorem stab_ntransitiveI : forall m x,
     x \in S ->  [transitive (G | to) on S]
  -> [transitive * m ('C_(G | to)[x] | to) on S :\ x]
  -> [transitive * m.+1 (G | to) on S].
Proof.
move=> m x Sx Gtr Gntr.
have t_to_x: forall t, t \in m.+1.-dtuple(S) ->
  exists2 a, a \in G & exists2 t', t' \in m.-dtuple(S :\ x)
                                 & t = n_act to [tuple of x :: t'] a.
- case/tupleP=> y t St.
  have Sy: y \in S by rewrite dtuple_on_add_D1 in St; case/andP: St.
  rewrite -(atransP Gtr _ Sy) in Sx; case/imsetP: Sx => a Ga toya.
  exists a^-1; first exact: groupVr.
  exists (n_act to t a); last by rewrite n_act_add toya !actK.
  move/(n_act_dtuple (subsetP (trans_acts Gtr) a Ga)): St.
  by rewrite n_act_add -toya dtuple_on_add_D1; case/andP.
case: (imsetP Gntr) => t dt S_tG; pose xt := [tuple of x :: t].
have dxt: xt \in m.+1.-dtuple(S) by rewrite dtuple_on_add_D1 Sx.
apply/imsetP; exists xt => //; apply/setP=> t2.
symmetry; apply/imsetP/idP=> [[a Ga ->] | ].
  by apply: n_act_dtuple; rewrite // (subsetP (trans_acts Gtr)).
case/t_to_x=> a2 Ga2 [t2']; rewrite S_tG.
case/imsetP=> a; case/setIP=> Ga; move/astab1P=> toxa -> -> {t2 t2'}.
by exists (a * a2); rewrite (groupM, actM) //= !n_act_add toxa.
Qed.

End NTransitveProp1.


Require Import Gappa_tactic.

Open Scope R_scope.

Goal forall fma x' x_ éà,
  fma = 1 ->
  x' = 2 ->
  x_ = 3 ->
  éà = 4 ->
  10 <= fma + x' + x_ + éà <= 10.
Proof.
gappa.
Qed.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj5synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (mult (Succ Zero) lv0) (plus (plus lv1 lv2) (mult lv3 lv2))).
Admitted.
QuickChick conj5synthconj3.