Require Import Relations Omega Ensembles Finite_sets Finite_sets_facts.
Require Import List ListSet.
Require Import util set_rep_equiv.

Require Import ListSet List Relations_1.
Require Import LibTactics.

Section strict_order.

Open Scope list_scope.

Variable X : Type.
 Hypothesis Xeq_dec : forall x y : X, {x=y}+{x<>y}.
Variable R : Relation X.

 Definition Irreflexive (X:Type) (R:Relation X) : Prop := forall x:X, ~R x x.
  Inductive StrictOrder (X:Type) (R:Relation X) : Prop :=
       Definition_of_order :
         Irreflexive X R -> Transitive X R -> StrictOrder X R.

 Hypothesis Rdec : forall (x y:X), {R x y} + {~R x y}.
 Hypothesis Rso : StrictOrder X R.

Fixpoint lt_set (pivot:X) (s:set X) : (set X) :=
match s with
| nil => nil
| x :: srest =>
  if Rdec x pivot
  then set_add Xeq_dec x (lt_set pivot srest)
  else lt_set pivot srest
end.

Lemma in_lt_imp_in_set : forall x y s,
set_In y (lt_set x s) ->
set_In y s.
Proof.
  intros x y s.
  induction s as [|h s'].
  Case "s = []".
    intros yIn. inversion yIn.
  Case "s = h :: s'".
    intros yIn.
    destruct (Xeq_dec y h) as [eqyh | neqyh].
    SCase "y = h".
      subst h. left. reflexivity.
    SCase "y <> h".
      right. apply IHs'.
      simpl in yIn.
      destruct (Rdec h x) as [Rhx | nRhx].
      SSCase "Rhx".
        apply set_add_elim in yIn.
        destruct yIn.
          contradiction.
          exact H.
      SSCase "~Rhx".
        exact yIn.
Qed.

Lemma lt_set_rel_equiv : forall x y s,
set_In y s ->
(R y x <-> set_In y (lt_set x s)).
Proof.
  intros x y s yIn.
  split.
  Case "Ryx -> In".
    intros Ryx.
    induction s as [| h s'].
      SCase "s = []".
        inversion yIn.
      SCase "s = h :: s'".
        destruct (Xeq_dec h y) as [eqyh | neqyh].
        SSCase "y = h".
          subst h. simpl.
          destruct (Rdec y x) as [yRyx | nRyx].
            apply set_add_intro2. reflexivity.
            contradiction.
        SSCase " y <> h".
          simpl.
          destruct (Rdec h x) as [yRhx | nRhx].
            apply set_add_intro1. apply IHs'.
            destruct yIn.
              contradiction. exact H.
            apply IHs'.
            destruct yIn.
              contradiction. exact H.
  Case "Ryx <- In".
    intros yInlt.
    induction s as [| h s'].
    SCase "s = []".
      inversion yIn.
    SCase "s = [h s']".
      destruct (Xeq_dec y h) as [eqyh | neqyh].
      SSCase "y = x".
        subst h. simpl in yInlt.
        destruct (Rdec y x) as [Ryx | nRyx].
          exact Ryx.
          apply IHs'.
          eapply in_lt_imp_in_set. exact yInlt.
          exact yInlt.
      SSCase "y <> h".
        destruct yIn.
          symmetry in H. contradiction.
          simpl in yInlt.
          destruct (Rdec h x) as [Rhx | nRhx].
            apply set_add_elim in yInlt.
            destruct yInlt.
              contradiction.
              apply IHs'. exact H. exact H0.
              apply IHs'. exact H. exact yInlt.
Qed.

Fixpoint gt_set (pivot:X) (s:set X) : (set X) :=
match s with
| nil => nil
| x :: srest =>
  if Rdec pivot x
  then set_add Xeq_dec x (gt_set pivot srest)
  else gt_set pivot srest
end.

Lemma in_gt_imp_in_set : forall x y s,
set_In y (gt_set x s) ->
set_In y s.
Proof.
  intros x y s.
  induction s as [|h s'].
  Case "s = []".
    intros yIn. inversion yIn.
  Case "s = h :: s'".
    intros yIn.
    destruct (Xeq_dec y h) as [eqyh | neqyh].
    SCase "y = h".
      subst h. left. reflexivity.
    SCase "y <> h".
      right. apply IHs'.
      simpl in yIn.
      destruct (Rdec x h) as [Rxh | nRxh].
      SSCase "Rxh".
        apply set_add_elim in yIn.
        destruct yIn.
          contradiction.
          exact H.
      SSCase "~Rxh".
        exact yIn.
Qed.

Lemma gt_set_rel_equiv : forall x y s,
set_In y s ->
(R x y <-> set_In y (gt_set x s)).
Proof.
  intros x y s yIn.
  split.
  Case "Rxy -> In".
    intros Rxy.
    induction s as [| h s'].
      SCase "s = []".
        inversion yIn.
      SCase "s = h :: s'".
        destruct (Xeq_dec h y) as [eqyh | neqyh].
        SSCase "y = h".
          subst h. simpl.
          destruct (Rdec x y) as [yRxy | nRxy].
            apply set_add_intro2. reflexivity.
            contradiction.
        SSCase " y <> h".
          simpl.
          destruct (Rdec x h) as [yRxh | nRxh].
            apply set_add_intro1. apply IHs'.
            destruct yIn.
              contradiction. exact H.
            apply IHs'.
            destruct yIn.
              contradiction. exact H.
  Case "Rxy <- In".
    intros yInlt.
    induction s as [| h s'].
    SCase "s = []".
      inversion yIn.
    SCase "s = [h s']".
      destruct (Xeq_dec y h) as [eqyh | neqyh].
      SSCase "y = h".
        subst h. simpl in yInlt.
        destruct (Rdec x y) as [Rxy | nRxy].
          exact Rxy.
          apply IHs'.
          eapply in_gt_imp_in_set. exact yInlt. exact yInlt.
      SSCase "y <> h".
        destruct yIn.
          symmetry in H. contradiction.
          simpl in yInlt.
          destruct (Rdec x h) as [Rxh | nRxh].
            apply set_add_elim in yInlt.
            destruct yInlt.
              contradiction.
              apply IHs'. exact H. exact H0.
              apply IHs'. exact H. exact yInlt.
Qed.

Fixpoint norel_set (pivot:X) (s:set X) : (set X) :=
match s with
| nil => nil
| x :: srest =>
  if Rdec x pivot
  then norel_set pivot srest
  else if Rdec pivot x
       then norel_set pivot srest
       else set_add Xeq_dec x (norel_set pivot srest)
end.

Lemma in_norel_imp_in_set : forall x y s,
set_In y (norel_set x s) ->
set_In y s.
Proof.
  intros x y s.
  induction s as [|h s'].
  Case "s = []".
    intros yIn. inversion yIn.
  Case "s = h :: s'".
    intros yIn.
    destruct (Xeq_dec y h) as [eqyh | neqyh].
    SCase "y = h".
      subst h. left. reflexivity.
    SCase "y <> h".
      right. apply IHs'.
      simpl in yIn.
      destruct (Rdec h x) as [Rhx | nRhx].
      SSCase "Rhx".
        exact yIn.
        destruct (Rdec x h) as [Rxh | nRxh].
        SSSCase "Rxh".
          exact yIn.
        SSCase "~Rxh".
          apply set_add_elim in yIn.
          destruct yIn.
            contradiction.
            exact H.
Qed.

Lemma norel_set_rel_equiv : forall x y s,
set_In y s ->
((and (~R x y) (~R y x)) <-> set_In y (norel_set x s)).
Proof.
  intros x y s yIn.
  split.
  Case "no relation -> In".
    intros Rand.
    destruct Rand as [nRxy nRyx].
    induction s as [| h s'].
      SCase "s = []".
        inversion yIn.
      SCase "s = h :: s'".
        destruct (Xeq_dec h y) as [eqyh | neqyh].
        SSCase "y = h".
          subst h. simpl.
          destruct (Rdec y x) as [yRyx | nRyx2].
          SSSCase "Ryx".
            contradiction.
          SSSCase "~Ryx".
            destruct (Rdec x y) as [yRxy | nRxy2].
            SSSSCase "Rxy".
              contradiction.
            SSSSCase "~Rxy".
              apply set_add_intro2. reflexivity.
        SSCase "y <> h".
          simpl.
          destruct (Rdec h x) as [yRhx | nRhx].
          SSSCase "Rhx".
            apply IHs'.
            destruct yIn.
              contradiction. exact H.
          SSSCase "~Rhx".
            destruct (Rdec x h) as [yRxh | nRxh].
            SSSSCase "Rxh".
              apply IHs'.
              destruct yIn.
                contradiction. exact H.
              apply set_add_intro1.
              apply IHs'.
              destruct yIn.
                contradiction. exact H.
  Case "no relation <- In".
    intros yInlt.
    induction s as [| h s'].
    SCase "s = []".
      inversion yIn.
    SCase "s = [h s']".
      destruct (Xeq_dec y h) as [eqyh | neqyh].
      SSCase "y = h".
        subst h. simpl in yInlt.
        destruct (Rdec x y) as [Rxy | nRxy].
        SSSCase "Rxy".
          destruct (Rdec y x) as [Ryx | nRyx].
          SSSSCase "Ryx".
            assert (R x x) as contraR.
              eapply Rso. exact Rxy. exact Ryx.
            apply Rso in contraR. inversion contraR.
          SSSSCase "~Ryx".
            apply IHs'.
            eapply in_norel_imp_in_set. exact yInlt.
            exact yInlt.
        SSSCase "~Rxy".
          destruct (Rdec y x) as [Ryx | nRyx].
          SSSSCase "Ryx".
            apply IHs'.
            eapply in_norel_imp_in_set. exact yInlt.
            exact yInlt.
          SSSSCase "~Ryx".
            split. exact nRxy. exact nRyx.
      SSCase "y <> h".
        apply IHs'.
        destruct yIn. symmetry in H. contradiction.
        exact H.
        simpl in yInlt.
        destruct (Rdec h x) as [Rhx | nRhx].
        SSSCase "Rhx".
          exact yInlt.
        SSSCase "~Rhx".
          destruct (Rdec x h) as [Rxh | nRxh].
          SSSSCase "Rxh".
            exact yInlt.
          SSSSCase "~Rxh".
            eapply set_add_elim in yInlt.
            destruct yInlt.
              contradiction.
              exact H.
Qed.

Lemma lt_set_only : forall x y s,
set_In y (lt_set x s) ->
~set_In y (gt_set x s) /\ ~set_In y (norel_set x s).
Proof.
  intros x y s yIn.
  split.
  Case "y not in gt".
    intros contraIn.
    apply lt_set_rel_equiv in yIn.
    apply gt_set_rel_equiv in contraIn.
    assert (R y y). eapply Rso. exact yIn. exact contraIn.
    eapply Rso. exact H.
    eapply in_gt_imp_in_set. exact contraIn.
    eapply in_gt_imp_in_set. exact contraIn.
  Case "y not in indiff".
    intros contraIn.
    apply norel_set_rel_equiv in contraIn. destruct contraIn.
    apply lt_set_rel_equiv in yIn.
    contradiction.
    eapply in_lt_imp_in_set. exact yIn.
    eapply in_lt_imp_in_set. exact yIn.
Qed.

Lemma gt_set_only : forall x y s,
set_In y (gt_set x s) ->
~set_In y (lt_set x s) /\ ~set_In y (norel_set x s).
Proof.
  intros x y s yIn.
  split.
  Case "y not in gt".
    intros contraIn.
    apply gt_set_rel_equiv in yIn.
    apply lt_set_rel_equiv in contraIn.
    eapply Rso. eapply Rso. exact yIn. exact contraIn.
    eapply in_lt_imp_in_set. exact contraIn.
    eapply in_gt_imp_in_set. exact yIn.
  Case "y not in indiff".
    intros contraIn.
    apply norel_set_rel_equiv in contraIn. destruct contraIn.
    apply gt_set_rel_equiv in yIn.
    contradiction.
    eapply in_gt_imp_in_set. exact yIn.
    eapply in_gt_imp_in_set. exact yIn.
Qed.

Lemma norel_set_only : forall x y s,
set_In y (norel_set x s) ->
~set_In y (lt_set x s) /\ ~set_In y (gt_set x s).
Proof.
  intros x y s yIn.
  split.
  Case "y not in lt".
    intros contraIn.
    apply lt_set_only in contraIn. destruct contraIn as [ngt nindiff].
    contradiction.
  Case "y not in gt".
    intros contraIn.
    apply gt_set_only in contraIn. destruct contraIn as [nlt nindiff].
    contradiction.
Qed.

Lemma lt_preserve_nodup : forall x s,
NoDup s ->
NoDup (lt_set x s).
Proof.
  intros x s.
  induction s as [| h rest].
  Case "s = []".
    intros nodup.
    simpl. constructor.
  Case "s = [h :: rest]".
    intros nodup.
    simpl.
    destruct (Rdec h x) as [Rhx |nRhx].
      inversion nodup; subst.
      apply set_add_nodup.
      constructor.
      intros contra. apply H1. eapply in_lt_imp_in_set.
      exact contra. apply IHrest. exact H2.
      apply IHrest. inversion nodup; auto.
Qed.

Lemma exists_empty_lt_set : forall s,
s <> nil ->
exists x, set_In x s /\ lt_set x s = nil.
Proof.
  intros s notempty.
  induction s as [| x1 s'].
  Case "s = []".
    assert False as F. apply notempty. reflexivity. inversion F.
  Case "S =  a :: s".
    destruct s' as [| x2 s''].
    SCase "s' = []".
      exists x1. simpl.
      destruct (Rdec x1 x1).
      assert False as F. eapply Rso. exact r. inversion F.
      split. left. reflexivity. reflexivity.
    SCase "s' = x2 :: s''".
      assert (x2 :: s'' <> nil) as notmt.
        intros contra. inversion contra.
      apply IHs' in notmt.
      destruct notmt as [m mltnil].
      destruct (Rdec x1 m).
      SSCase "R x1 m".
        exists x1. simpl.
        destruct (Rdec x1 x1).
        apply Rso in r0. inversion r0.
        destruct (Rdec x2 x1).
        SSSCase "R x2 x1".
          assert (set_In x2 (lt_set m (x2 :: s''))) as contra.
          eapply lt_set_rel_equiv. left. reflexivity.
          eapply Rso. exact r0. exact r.
          split. left. reflexivity.
          destruct mltnil as [mltnilIn mltnil].
          rewrite mltnil in contra. inversion contra.
          SSSCase "~R x2 x1".
            remember (lt_set x1 s'') as x1lt.
            destruct (x1lt).
            SSSSCase "lt_set x1 s'' = []". split. left. reflexivity. reflexivity.
            SSSSCase "x :: x1lt = lt_set x1 s''".
              assert (set_In x (lt_set x1 s'')) as xInx1lt.
              rewrite <- Heqx1lt. left. reflexivity.
              assert (set_In x s'') as xcontraIn.
              eapply in_lt_imp_in_set. exact xInx1lt.
              assert (R x m) as Rxm.
              eapply Rso. apply lt_set_rel_equiv in xInx1lt.
              exact xInx1lt. exact xcontraIn. exact r.
              assert (set_In x (lt_set m (x2 :: s''))) as contraInmlt.
              apply lt_set_rel_equiv. right. exact xcontraIn. exact Rxm.
              split. left. reflexivity.
              destruct mltnil as [mltnilIn mltnil].
              rewrite mltnil in contraInmlt. inversion contraInmlt.
      SSCase "~R x1 m".
        exists m.
        split.
        destruct mltnil as [mltnilIn mltnil].
        right. exact mltnilIn.
        destruct mltnil as [mltnilIn mltnil].
        simpl. destruct (Rdec x1 m). contradiction.
        exact mltnil.
Qed.

Theorem minimal_set_mem :
  forall (s: set X),
    s = nil \/ (exists min, set_In min s /\
                           forall y, set_In y s -> ~R y min).
Proof.
  intros s.
  destruct s.
  left; auto.
  right.
  edestruct (exists_empty_lt_set (x::s)).
  intros contra. inversion contra.
  destruct H.
  exists x0. split; auto.
  intros y yIn contraR.
  forwards*: (lt_set_rel_equiv x0 y).
  apply H1 in contraR. rewrite H0 in contraR.
  inversion contraR.
Qed.

End strict_order.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(** * Fixing implicit types *)

Implicit Arguments inl [[A] [B]].
Implicit Arguments inr [[A] [B]].

(* ********************************************************************** *)
(** * Inhabited *)

Instance sum_inhab_left : forall `{Inhab A} B, Inhab (A + B).
Proof using. intros. apply (prove_Inhab (inl arbitrary)). Qed.
Instance sum_inhab_right : forall `{Inhab B} A, Inhab (A + B).
Proof using. intros. apply (prove_Inhab (inr arbitrary)). Qed.

Definition sum_inhab : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof using. typeclass. Qed.

(* ********************************************************************** *)
(** * Operations *)

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Definition is_inl x :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr x :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof using. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof using. intros x. destruct~ x. Qed.

End IsIn.

(* ********************************************************************** *)
(** * Projections *)

(*-----------------------------------------------------*)
(** ** Stripping of the branch tag *)

Section Get.
Variables (A1 A2 : Type) (DA1:Inhab A1) (DA2:Inhab A2).
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

Implicit Arguments get21 [[A1] [A2] [DA1]].
Implicit Arguments get22 [[A1] [A2] [DA2]].

(*-----------------------------------------------------*)
(** ** Lifting functions over sum types *)

Section Fget.
Variables (A1 A2 B1 B2 : Type)
  (DB1:Inhab B1) (DB2:Inhab B2).
Implicit Types f : A1+A2->B1+B2.

Definition func_get21 f :=
  fun x => get21 (f (inl x)).
Definition func_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.

Implicit Arguments func_get21 [[A1] [A2] [B1] [B2] [DB1]].
Implicit Arguments func_get22 [[A1] [A2] [B1] [B2] [DB2]].


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrbool ssrfun eqtype ssrnat fintype finset.
From mathcomp
Require Import fingroup perm morphism.

(******************************************************************************)
(* Group automorphisms and characteristic subgroups.                          *)
(* Unlike morphisms on a group G, which are functions of type gT -> rT, with  *)
(* a canonical structure of dependent type {morphim G >-> rT}, automorphisms  *)
(* are permutations of type {perm gT} contained in Aut G : {set {perm gT}}.   *)
(* This lets us use the finGroupType of {perm gT}. Note also that while       *)
(* morphisms on G are undefined outside G, automorphisms have their support   *)
(* in G, i.e., they are the identity outside G.                               *)
(* Definitions:                                                               *)
(*    Aut G (or [Aut G]) == the automorphism group of G.                      *)
(*             [Aut G]%G == the group structure for Aut G.                    *)
(*            autm AutGa == the morphism on G induced by a, given             *)
(*                          AutGa : a \in Aut G.                              *)
(*       perm_in injf fA == the permutation with support B in induced by f,   *)
(*                          given injf : {in A &, injective f} and            *)
(*                          fA : f @: A \subset A.                            *)
(*           aut injf fG == the automorphism of G induced by the morphism f,  *)
(*                          given injf : 'injm f and fG : f @* G \subset G.   *)
(*    Aut_isom injf sDom == the injective homomorphism that maps Aut G to     *)
(*                          Aut (f @* G), with f : {morphism D >-> rT} and    *)
(*                          given injf: 'injm f and sDom : G \subset D.       *)
(*              conjgm G == the conjugation automorphism on G.                *)
(*             H \char G == H is a characteristic subgroup of G.              *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GroupScope.

(***********************************************************************)
(* A group automorphism, defined as a permutation on a subset of a     *)
(* finGroupType that respects the morphism law.                        *)
(* Here perm_on is used as a closure rule for the set A.               *)
(***********************************************************************)

Section Automorphism.

Variable gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types a b : {perm gT}.

Definition Aut A := [set a | perm_on A a & morphic A a].

Lemma Aut_morphic A a : a \in Aut A -> morphic A a.
Proof. by case/setIdP. Qed.

Lemma out_Aut A a x : a \in Aut A -> x \notin A -> a x = x.
Proof. by case/setIdP=> Aa _; apply: out_perm. Qed.

Lemma eq_Aut A : {in Aut A &, forall a b, {in A, a =1 b} -> a = b}.
Proof.
move=> a g Aa Ag /= eqag; apply/permP=> x.
by have [/eqag // | /out_Aut out] := boolP (x \in A); rewrite !out.
Qed.

(* The morphism that is represented by a given element of Aut A. *)

Definition autm A a (AutAa : a \in Aut A) := morphm (Aut_morphic AutAa).
Lemma autmE A a (AutAa : a \in Aut A) : autm AutAa = a.
Proof. by []. Qed.

Canonical autm_morphism A a aM := Eval hnf in [morphism of @autm A a aM].

Section AutGroup.

Variable G : {group gT}.

Lemma Aut_group_set : group_set (Aut G).
Proof.
apply/group_setP; split=> [|a b].
  by rewrite inE perm_on1; apply/morphicP=> ? *; rewrite !permE.
rewrite !inE => /andP[Ga aM] /andP[Gb bM]; rewrite perm_onM //=.
apply/morphicP=> x y Gx Gy; rewrite !permM (morphicP aM) //.
by rewrite (morphicP bM) ?perm_closed.
Qed.

Canonical Aut_group := group Aut_group_set.

Variable (a : {perm gT}) (AutGa : a \in Aut G).
Notation f := (autm AutGa).
Notation fE := (autmE AutGa).

Lemma injm_autm : 'injm f.
Proof. by apply/injmP; apply: in2W; apply: perm_inj. Qed.

Lemma ker_autm : 'ker f = 1. Proof. by move/trivgP: injm_autm. Qed.

Lemma im_autm : f @* G = G.
Proof.
apply/setP=> x; rewrite morphimEdom (can_imset_pre _ (permK a)) inE.
by have:= AutGa; rewrite inE => /andP[/perm_closed <-]; rewrite permKV.
Qed.

Lemma Aut_closed x : x \in G -> a x \in G.
Proof. by move=> Gx; rewrite -im_autm; apply: mem_morphim. Qed.

End AutGroup.

Lemma Aut1 : Aut 1 = 1.
Proof.
apply/trivgP/subsetP=> a /= AutGa; apply/set1P.
apply: eq_Aut (AutGa) (group1 _) _ => _ /set1P->.
by rewrite -(autmE AutGa) morph1 perm1.
Qed.

End Automorphism.

Arguments Aut _ _%g.
Notation "[ 'Aut' G ]" := (Aut_group G)
  (at level 0, format "[ 'Aut'  G ]") : Group_scope.
Notation "[ 'Aut' G ]" := (Aut G)
  (at level 0, only parsing) : group_scope.

Prenex Implicits Aut autm.

(* The permutation function (total on the underlying groupType) that is the *)
(* representant of a given morphism f with domain A in (Aut A).             *)

Section PermIn.

Variables (T : finType) (A : {set T}) (f : T -> T).

Hypotheses (injf : {in A &, injective f}) (sBf : f @: A \subset A).

Lemma perm_in_inj : injective (fun x => if x \in A then f x else x).
Proof.
move=> x y /=; wlog Ay: x y / y \in A.
  by move=> IH eqfxy; case: ifP (eqfxy); [symmetry | case: ifP => //]; auto.
rewrite Ay; case: ifP => [Ax | nAx def_x]; first exact: injf.
by case/negP: nAx; rewrite def_x (subsetP sBf) ?mem_imset.
Qed.

Definition perm_in := perm perm_in_inj.

Lemma perm_in_on : perm_on A perm_in.
Proof.
by apply/subsetP=> x; rewrite inE /= permE; case: ifP => // _; case/eqP.
Qed.

Lemma perm_inE : {in A, perm_in =1 f}.
Proof. by move=> x Ax; rewrite /= permE Ax. Qed.

End PermIn.

(* properties of injective endomorphisms *)

Section MakeAut.

Variables (gT : finGroupType) (G : {group gT}) (f : {morphism G >-> gT}).
Implicit Type A : {set gT}.

Hypothesis injf : 'injm f.

Lemma morphim_fixP A : A \subset G -> reflect (f @* A = A) (f @* A \subset A).
Proof.
rewrite /morphim => sAG; have:= eqEcard (f @: A) A.
rewrite (setIidPr sAG) card_in_imset ?leqnn ?andbT  => [<-|]; first exact: eqP.
by move/injmP: injf; apply: sub_in2; apply/subsetP.
Qed.

Hypothesis Gf : f @* G = G.

Lemma aut_closed : f @: G \subset G.
Proof. by rewrite -morphimEdom; apply/morphim_fixP. Qed.

Definition aut := perm_in (injmP injf) aut_closed.

Lemma autE : {in G, aut =1 f}.
Proof. exact: perm_inE. Qed.

Lemma morphic_aut : morphic G aut.
Proof. by apply/morphicP=> x y Gx Gy /=; rewrite !autE ?groupM // morphM. Qed.

Lemma Aut_aut : aut \in Aut G.
Proof. by rewrite inE morphic_aut perm_in_on. Qed.

Lemma imset_autE A : A \subset G -> aut @: A = f @* A.
Proof.
move=> sAG; rewrite /morphim (setIidPr sAG).
by apply: eq_in_imset; apply: sub_in1 autE; apply/subsetP.
Qed.

Lemma preim_autE A : A \subset G -> aut @^-1: A = f @*^-1 A.
Proof.
move=> sAG; apply/setP=> x; rewrite !inE permE /=.
by case Gx: (x \in G) => //; apply/negP=> Ax; rewrite (subsetP sAG) in Gx.
Qed.

End MakeAut.

Arguments morphim_fixP {gT G f}.
Prenex Implicits aut.

Section AutIsom.

Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).

Hypotheses (injf : 'injm f) (sGD : G \subset D).
Let domG := subsetP sGD.

Lemma Aut_isom_subproof a :
  {a' | a' \in Aut (f @* G) & a \in Aut G -> {in G, a' \o f =1 f \o a}}.
Proof.
set Aut_a := autm (subgP (subg [Aut G] a)).
have aDom: 'dom (f \o Aut_a \o invm injf) = f @* G.
  rewrite /dom /= morphpre_invm -morphpreIim; congr (f @* _).
  by rewrite [_ :&: D](setIidPl _) ?injmK ?injm_autm ?im_autm.
have [af [def_af ker_af _ im_af]] := domP _ aDom.
have inj_a': 'injm af by rewrite ker_af !injm_comp ?injm_autm ?injm_invm.
have im_a': af @* (f @* G) = f @* G.
  by rewrite im_af !morphim_comp morphim_invm // im_autm.
pose a' := aut inj_a' im_a'; exists a' => [|AutGa x Gx]; first exact: Aut_aut.
have Dx := domG Gx; rewrite /= [a' _]autE ?mem_morphim //.
by rewrite def_af /= invmE // autmE subgK.
Qed.

Definition Aut_isom a := s2val (Aut_isom_subproof a).

Lemma Aut_Aut_isom a : Aut_isom a \in Aut (f @* G).
Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed.

Lemma Aut_isomE a : a \in Aut G -> {in G, forall x, Aut_isom a (f x) = f (a x)}.
Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed.

Lemma Aut_isomM : {in Aut G &, {morph Aut_isom: x y / x * y}}.
Proof.
move=> a b AutGa AutGb.
apply: (eq_Aut (Aut_Aut_isom _)); rewrite ?groupM ?Aut_Aut_isom // => fx.
case/morphimP=> x Dx Gx ->{fx}.
by rewrite permM !Aut_isomE ?groupM /= ?permM ?Aut_closed.
Qed.
Canonical Aut_isom_morphism := Morphism Aut_isomM.

Lemma injm_Aut_isom : 'injm Aut_isom.
Proof.
apply/injmP=> a b AutGa AutGb eq_ab'; apply: (eq_Aut AutGa AutGb) => x Gx.
by apply: (injmP injf); rewrite ?domG ?Aut_closed // -!Aut_isomE //= eq_ab'.
Qed.

End AutIsom.

Section InjmAut.

Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).

Hypotheses (injf : 'injm f) (sGD : G \subset D).
Let domG := subsetP sGD.

Lemma im_Aut_isom : Aut_isom injf sGD @* Aut G = Aut (f @* G).
Proof.
apply/eqP; rewrite eqEcard; apply/andP; split.
  by apply/subsetP=> _ /morphimP[a _ AutGa ->]; apply: Aut_Aut_isom.
have inj_isom' := injm_Aut_isom (injm_invm injf) (morphimS _ sGD).
rewrite card_injm ?injm_Aut_isom // -(card_injm inj_isom') ?subset_leq_card //.
apply/subsetP=> a /morphimP[a' _ AutfGa' def_a].
by rewrite -(morphim_invm injf sGD) def_a Aut_Aut_isom.
Qed.

Lemma Aut_isomP : isom (Aut G) (Aut (f @* G)) (Aut_isom injf sGD).
Proof. by apply/isomP; split; [apply: injm_Aut_isom | apply: im_Aut_isom]. Qed.

Lemma injm_Aut : Aut (f @* G) \isog Aut G.
Proof. by rewrite isog_sym (isom_isog _ _ Aut_isomP). Qed.

End InjmAut.

(* conjugation automorphism *)

Section ConjugationMorphism.

Variable gT : finGroupType.
Implicit Type A : {set gT}.

Definition conjgm of {set gT} := fun x y : gT => y ^ x.

Lemma conjgmE A x y : conjgm A x y = y ^ x. Proof. by []. Qed.

Canonical conjgm_morphism A x :=
  @Morphism _ _ A (conjgm A x) (in2W (fun y z => conjMg y z x)).

Lemma morphim_conj A x B : conjgm A x @* B = (A :&: B) :^ x.
Proof. by []. Qed.

Variable G : {group gT}.

Lemma injm_conj x : 'injm (conjgm G x).
Proof. by apply/injmP; apply: in2W; apply: conjg_inj. Qed.

Lemma conj_isom x : isom G (G :^ x) (conjgm G x).
Proof. by apply/isomP; rewrite morphim_conj setIid injm_conj. Qed.

Lemma conj_isog x : G \isog G :^ x.
Proof. exact: isom_isog (conj_isom x). Qed.

Lemma norm_conjg_im x : x \in 'N(G) -> conjgm G x @* G = G.
Proof. by rewrite morphimEdom; apply: normP. Qed.

Lemma norm_conj_isom x : x \in 'N(G) -> isom G G (conjgm G x).
Proof. by move/norm_conjg_im/restr_isom_to/(_ (conj_isom x))->. Qed.

Definition conj_aut x := aut (injm_conj _) (norm_conjg_im (subgP (subg _ x))).

Lemma norm_conj_autE : {in 'N(G) & G, forall x y, conj_aut x y = y ^ x}.
Proof. by move=> x y nGx Gy; rewrite /= autE //= subgK. Qed.

Lemma conj_autE : {in G &, forall x y, conj_aut x y = y ^ x}.
Proof. by apply: sub_in11 norm_conj_autE => //; apply: subsetP (normG G). Qed.

Lemma conj_aut_morphM : {in 'N(G) &, {morph conj_aut : x y / x * y}}.
Proof.
move=> x y nGx nGy; apply/permP=> z /=; rewrite permM.
case Gz: (z \in G); last by rewrite !permE /= !Gz.
by rewrite !norm_conj_autE // (conjgM, memJ_norm, groupM).
Qed.

Canonical conj_aut_morphism := Morphism conj_aut_morphM.

Lemma ker_conj_aut : 'ker conj_aut = 'C(G).
Proof.
apply/setP=> x; rewrite inE; case nGx: (x \in 'N(G)); last first.
  by symmetry; apply/idP=> cGx; rewrite (subsetP (cent_sub G)) in nGx.
rewrite 2!inE /=; apply/eqP/centP=> [cx1 y Gy | cGx].
  by rewrite /commute (conjgC y) -norm_conj_autE // cx1 perm1.
apply/permP=> y; case Gy: (y \in G); last by rewrite !permE Gy.
by rewrite perm1 norm_conj_autE // conjgE -cGx ?mulKg.
Qed.

Lemma Aut_conj_aut A : conj_aut @* A \subset Aut G.
Proof. by apply/subsetP=> _ /imsetP[x _ ->]; apply: Aut_aut. Qed.

End ConjugationMorphism.

Arguments conjgm _ _%g.
Prenex Implicits conjgm conj_aut.

Reserved Notation "G \char H" (at level 70).

(* Characteristic subgroup *)

Section Characteristicity.

Variable gT : finGroupType.
Implicit Types A B : {set gT}.
Implicit Types G H K L : {group gT}.

Definition characteristic A B :=
  (A \subset B) && [forall f in Aut B, f @: A \subset A].

Infix "\char" := characteristic.

Lemma charP H G :
  let fixH (f : {morphism G >-> gT}) := 'injm f -> f @* G = G -> f @* H = H in
  reflect [/\ H \subset G & forall f, fixH f] (H \char G).
Proof.
do [apply: (iffP andP) => -[sHG chHG]; split] => // [f injf Gf|].
  by apply/morphim_fixP; rewrite // -imset_autE ?(forall_inP chHG) ?Aut_aut.
apply/forall_inP=> f Af; rewrite -(autmE Af) -morphimEsub //.
by rewrite chHG ?injm_autm ?im_autm.
Qed.

(* Characteristic subgroup properties : composition, relational properties *)

Lemma char1 G : 1 \char G.
Proof. by apply/charP; split=> [|f _ _]; rewrite (sub1G, morphim1). Qed.

Lemma char_refl G : G \char G.
Proof. exact/charP. Qed.

Lemma char_trans H G K : K \char H -> H \char G -> K \char G.
Proof.
case/charP=> sKH chKH; case/charP=> sHG chHG.
apply/charP; split=> [|f injf Gf]; first exact: subset_trans sHG.
rewrite -{1}(setIidPr sKH) -(morphim_restrm sHG) chKH //.
  by rewrite ker_restrm; move/trivgP: injf => ->; apply: subsetIr.
by rewrite morphim_restrm setIid chHG.
Qed.

Lemma char_norms H G : H \char G -> 'N(G) \subset 'N(H).
Proof.
case/charP=> sHG chHG; apply/normsP=> x /normP-Nx.
have:= chHG [morphism of conjgm G x] => /=.
by rewrite !morphimEsub //=; apply; rewrite // injm_conj.
Qed.

Lemma char_sub A B : A \char B -> A \subset B.
Proof. by case/andP. Qed.

Lemma char_norm_trans H G A : H \char G -> A \subset 'N(G) -> A \subset 'N(H).
Proof. by move/char_norms=> nHnG nGA; apply: subset_trans nHnG. Qed.

Lemma char_normal_trans H G K : K \char H -> H <| G -> K <| G.
Proof.
move=> chKH /andP[sHG nHG].
by rewrite /normal (subset_trans (char_sub chKH)) // (char_norm_trans chKH).
Qed.

Lemma char_normal H G : H \char G -> H <| G.
Proof. by move/char_normal_trans; apply; apply/andP; rewrite normG. Qed.

Lemma char_norm H G : H \char G -> G \subset 'N(H).
Proof. by case/char_normal/andP. Qed.

Lemma charI G H K : H \char G -> K \char G -> H :&: K \char G.
Proof.
case/charP=> sHG chHG; case/charP=> _ chKG.
apply/charP; split=> [|f injf Gf]; first by rewrite subIset // sHG.
by rewrite morphimGI ?(chHG, chKG) //; apply: subset_trans (sub1G H).
Qed.

Lemma charY G H K : H \char G -> K \char G -> H <*> K \char G.
Proof.
case/charP=> sHG chHG; case/charP=> sKG chKG.
apply/charP; split=> [|f injf Gf]; first by rewrite gen_subG subUset sHG.
by rewrite morphim_gen ?(morphimU, subUset, sHG, chHG, chKG).
Qed.

Lemma charM G H K : H \char G -> K \char G -> H * K \char G.
Proof.
move=> chHG chKG; rewrite -norm_joinEl ?charY //.
exact: subset_trans (char_sub chHG) (char_norm chKG).
Qed.

Lemma lone_subgroup_char G H :
  H \subset G -> (forall K, K \subset G -> K \isog H -> K \subset H) ->
  H \char G.
Proof.
move=> sHG Huniq; apply/charP; split=> // f injf Gf; apply/eqP.
have{injf} injf: {in H &, injective f}.
  by move/injmP: injf; apply: sub_in2; apply/subsetP.
have fH: f @* H = f @: H by rewrite /morphim (setIidPr sHG).
rewrite eqEcard {2}fH card_in_imset ?{}Huniq //=.
  by rewrite -{3}Gf morphimS.
rewrite isog_sym; apply/isogP.
exists [morphism of restrm sHG f] => //=; first exact/injmP.
by rewrite morphimEdom fH.
Qed.

End Characteristicity.

Arguments characteristic _ _%g _%g.
Notation "H \char G" := (characteristic H G) : group_scope.
Hint Resolve char_refl : core.

Section InjmChar.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).

Hypothesis injf : 'injm f.

Lemma injm_char (G H : {group aT}) :
  G \subset D -> H \char G -> f @* H \char f @* G.
Proof.
move=> sGD /charP[sHG charH].
apply/charP; split=> [|g injg gfG]; first exact: morphimS.
have /domP[h [_ ker_h _ im_h]]: 'dom (invm injf \o g \o f) = G.
  by rewrite /dom /= -(morphpreIim g) (setIidPl _) ?injmK // gfG morphimS.
have hH: h @* H = H.
  apply: charH; first by rewrite ker_h !injm_comp ?injm_invm.
  by rewrite im_h !morphim_comp gfG morphim_invm.
rewrite /= -{2}hH im_h !morphim_comp morphim_invmE morphpreK //.
by rewrite (subset_trans _ (morphimS f sGD)) //= -{3}gfG !morphimS.
Qed.

End InjmChar.

Section CharInjm.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Hypothesis injf : 'injm f.

Lemma char_injm (G H : {group aT}) :
  G \subset D -> H \subset D -> (f @* H \char f @* G) = (H \char G).
Proof.
move=> sGD sHD; apply/idP/idP; last exact: injm_char.
by move/(injm_char (injm_invm injf)); rewrite !morphim_invm ?morphimS // => ->.
Qed.

End CharInjm.

Unset Implicit Arguments.


(**
SimSoC-Cert, a toolkit for generating certified processor simulators.

See the COPYRIGHTS and LICENSE files.

Bit vectors, based on Compcert.Integers file.

Defines the following implicit coercions:

regnum, byte, half, address, word > Z
bool > word
nat > regnum > word
byte > word
half > word
address > word
word > long
*)

Set Implicit Arguments.

Require Import Util ZArith Coqlib Integers.
Export Int.

(****************************************************************************)
(** A2.1 Data types (p. 39) *)
(****************************************************************************)

Inductive size : Type := Byte | Half | Word.

(****************************************************************************)
(** 32-bits words, masks and bit operations *)
(****************************************************************************)

Module Word := Int.

Notation word := int.
Notation mk_word := mkint.

Implicit Arguments mkint [intval].

Coercion intval : word >-> Z.

Notation w0 := zero.
Notation w1 := one.

Definition word_of_bool (b : bool) : word := if b then w1 else w0.

Coercion word_of_bool : bool >-> word.

Definition bool_of_word (w: word) : bool := zne w 0.

(* mask made of the bits n to n+k *)
Fixpoint masks_aux (n k : nat) : Z :=
  match k with
    | O => two_power_nat n
    | S k' => two_power_nat n + masks_aux (S n) k'
  end.

(* mask made of the bits n to n+(p-n) (p>=n) *)
Definition masks (p n : nat) : word := repr (masks_aux n (p-n)).
Definition anti_masks p n := not (masks p n).

(* mask made of bit n *)
Definition mask n := masks n n.
Definition anti_mask n := anti_masks n n.

(* word made of the bits p to n of w (p>=n) *)
Definition bits_val (p n : nat) (w : word) : Z :=
  and (masks p n) w / two_power_nat n.

Definition bits (p n : nat) (w : word) : word := repr (bits_val p n w).
Notation "w [ p # n ]" := (bits p n w) (at level 8).

Definition byte0 (w : word) : word := bits 7 0 w.
Definition byte1 (w : word) : word := bits 15 8 w.
Definition byte2 (w : word) : word := bits 23 16 w.
Definition byte3 (w : word) : word := bits 31 24 w.

(* n-th bit of w *)
Definition bit (n : nat) (w : word) : word := bits n n w.
Notation get := bit.
Notation "w [ n ]" := (bit n w) (at level 8).

(* tell if w[n] is set to 1 *)
Definition is_set (n : nat) (w : word) : bool := zne w[n] 0.

(* tell if a signed word is negative *)
Definition is_neg (w : word) : bool := is_set 31 w.

(* set w[n] to 1 *)
Definition set (n : nat) (w : word) : word := or (mask n) w.

(* set w[n] to 0 *)
Definition clear (n : nat) (w : word) : word := and (anti_mask n) w.

(* set w[n] to 1 if b=true, and 0 if b=false *)
Definition set_bit_aux (n : nat) (b : bool) (w : word) : word :=
  if b then set n w else clear n w.

(* set w[n] to 1 if v<>0, and 0 if v=0 *)
Definition set_bit (n : nat) (v w : word) : word := set_bit_aux n (zne v 0) w.

(* set w[p:p-k] to v[k:0] *)
Fixpoint set_bits_aux (p k : nat) (v w : word) : word :=
  match k with
    | O => set_bit p v[0] w
    | S k' => set_bits_aux (pred p) k' v (set_bit p v[k] w)
  end.

(* set w[p:n] to v[p-n:0] (p>=n) *)
Definition set_bits (p n : nat) (v w : word) : word :=
  set_bits_aux p (p-n) v w.

(****************************************************************************)
(** convert word to type w32 to make the decoder faster *)
(****************************************************************************)

Require Import NaryFunctions Util.

Inductive w32 : Type := word32 : bool^^32 --> w32.

Definition w32_of_word (w : int) : w32 :=
  nary_iter_decr (bits_of_Z 32 (unsigned w)) 32 31 word32.

Inductive w28 : Type := word28 : bool^^28 --> w28.

Definition w28_of_word (w : int) : w28 :=
  nary_iter_decr (bits_of_Z 28 (unsigned w)) 28 27 word28.

Inductive w16 : Type := word16 : bool^^16 --> w16.

Definition w16_of_word (w : int) : w16 :=
  nary_iter_decr (bits_of_Z 16 (unsigned w)) 16 15 word16.

Inductive w4 : Type := word4 : bool^^4 --> w4.

Definition w32_first4bits_of_word (w : int) : w4 :=
  nary_iter_decr (bits_of_Z 32 (unsigned w)) 4 31 word4.

Remark correct_get_first4bits : forall w,
  match w32_of_word w with
    | word32 a b c d _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ => (a, b, c, d)
  end
  =
  match w32_first4bits_of_word w with
    | word4 a b c d => (a, b, c, d)
  end.
  trivial.
Qed.

(****************************************************************************)
(** bytes (8-bits words) *)
(****************************************************************************)

Notation mk_byte := Byte.repr.

Coercion Byte.intval : byte >-> Z.

(*FIXME: uncomment when Util.two_power_nat_monotone is proved

Lemma byte_in_range : forall b : byte, 0 <= b < Word.modulus.

Proof.
intros [x h]. simpl. unfold Byte.modulus in h. unfold modulus.
assert (two_power_nat Byte.wordsize <= two_power_nat wordsize).
apply two_power_nat_monotone. omega.
Qed.

Definition word_of_byte (x : byte) : word := mkint (byte_in_range x).*)

Definition word_of_byte (x : byte) : word := repr x.

Coercion word_of_byte : byte >-> word.

Definition get_byte0 w := mk_byte (w[7#0]).
Definition get_byte1 w := mk_byte (w[15#8]).
Definition get_byte2 w := mk_byte (w[23#16]).
Definition get_byte3 w := mk_byte (w[31#24]).
Definition get_signed_byte0 w := Word.repr (Byte.signed (mk_byte (w[7#0]))).
Definition get_signed_byte1 w := Word.repr (Byte.signed (mk_byte (w[15#8]))).
Definition get_signed_byte2 w := Word.repr (Byte.signed (mk_byte (w[23#16]))).
Definition get_signed_byte3 w := Word.repr (Byte.signed (mk_byte (w[31#24]))).

(****************************************************************************)
(** half-words (16-bits words) *)
(****************************************************************************)

Module Wordsize_16.
  Definition wordsize := 16%nat.
  Remark wordsize_not_zero: wordsize <> 0%nat.
  Proof. unfold wordsize; congruence. Qed.
End Wordsize_16.

Module Half := Make(Wordsize_16).

Notation half := Half.int.
Notation mk_half := Half.repr.

Coercion Half.intval : half >-> Z.

(*IMPROVE*)
Definition word_of_half (x : half) : word := repr x.

Coercion word_of_half : half >-> word.

Definition get_half0 w := mk_half (w[15#0]).
Definition get_half1 w := mk_half (w[31#16]).
Definition get_signed_half0 w := Word.repr (Half.signed (mk_half (w[15#0]))).
Definition get_signed_half1 w := Word.repr (Half.signed (mk_half (w[31#16]))).

(****************************************************************************)
(** A2.3 Registers (p. 42) *)
(****************************************************************************)

Module Wordsize_4.
  Definition wordsize := 4%nat.
  Remark wordsize_not_zero: wordsize <> 0%nat.
  Proof. unfold wordsize; congruence. Qed.
End Wordsize_4.

Module Regnum := Make(Wordsize_4).

Notation regnum := Regnum.int.
Notation mk_regnum := Regnum.repr.

Coercion Regnum.intval : regnum >-> Z.

(*IMPROVE*)
Definition word_of_regnum (x : regnum) : word := repr x.

Coercion word_of_regnum : regnum >-> word.

(*IMPROVE: can be improved by using build_bitvec instead of mk_bitvec
since [bits (k+3) k w] is always smaller than [two_power_nat 4]*)
Definition regnum_from_bit (k : nat) (w : word) : regnum :=
  mk_regnum (bits (k+3) k w).

Definition regnum_of_nat (n : nat) : regnum := mk_regnum (Z_of_nat n).

Coercion regnum_of_nat : nat >-> regnum.

(****************************************************************************)
(** Addresses (p. 68) *)
(****************************************************************************)

Module Wordsize_30.
  Definition wordsize := 30%nat.
  Remark wordsize_not_zero: wordsize <> 0%nat.
  Proof. unfold wordsize; congruence. Qed.
End Wordsize_30.

Module Address := Make(Wordsize_30).

Notation address := Address.int.
Notation mk_address := Address.repr.

(*REMOVE: Coercion Address.intval : address >-> Z. *)

(*IMPROVE*)
Definition word_of_address (x : address) : word := repr (Address.intval x).

(*REMOVE: Coercion word_of_address : address >-> word. *)

(*REMOVE:Definition address_eqdec := @bitvec_eqdec address_size.*)

(*IMPROVE: can be improved by using build_bitvec instead of mk_bitvec
since [bits 31 2 w] is always smaller than [two_power_nat 30]*)
Definition address_of_word (w : word) : address := mk_address (bits 31 2 w).

(****************************************************************************)
(** 64-bits words *)
(****************************************************************************)

Module Wordsize_64.
  Definition wordsize := 64%nat.
  Remark wordsize_not_zero: wordsize <> 0%nat.
  Proof. unfold wordsize; congruence. Qed.
End Wordsize_64.

Module Long := Make(Wordsize_64).

Notation long := Long.int.
Notation mk_long := Long.repr.

Coercion Long.intval : long >-> Z.

(*IMPROVE*)
Definition long_of_word (x : word) : long := mk_long x.

Coercion long_of_word : word >-> long.

(****************************************************************************)
(** operations on 64 bits *)
(****************************************************************************)

Definition masks64 (p n : nat) : long := mk_long (masks_aux n (p-n)).

Definition bits_val64 (p n : nat) (w : long) : Z :=
  Long.and (masks64 p n) w / two_power_nat n.

Definition sbits64 (p n : nat) (w : long) : Z := Word.signed (repr (bits_val64 p n w)).

Definition unsbits64 (p n : nat) (w : long) : Z := Word.unsigned (repr (bits_val64 p n w)).

Definition unsigned_mul64 (w1 w2 : word) : long :=
  Long.mul w1 w2.

Definition signed_mul64 (w1 w2 : word) : long :=
  match Word.signed w1, Word.signed w2 with
    | Z0, _ | _, Z0 => mk_long Z0
    | Zpos w1', Zpos w2' | Zneg w1', Zneg w2' =>
      mk_long (Zpos (w1' * w2'))
    | Zpos w1', Zneg w2' | Zneg w1', Zpos w2' =>
      mk_long (Zneg (w1' * w2'))
  end.

Definition bits_of_unsigned_mul64 (w1 w2 : word) (n1 n2 : nat) : word :=
  repr (unsbits64 n1 n2 (unsigned_mul64 w1 w2)).

Definition bits_of_signed_mul64 (w1 w2 : word) (n1 n2 : nat) : word :=
  repr (sbits64 n1 n2 (signed_mul64 w1 w2)).

Definition to64 (hi : word) (lo : word) :=
  Long.or (Long.shl hi (repr 32)) lo.

Definition or64 := Long.or.
Definition add64 := Long.add.
Definition mul64 := unsigned_mul64.
Definition sub64 := Long.sub.
Definition Logical_Shift_Left64 := Long.shl.

Definition get_hi (l : long) :=
  Word.repr (sbits64 63 32 l).

Definition get_lo (l : long) :=
  Word.repr (sbits64 31 0 l).

(****************************************************************************)
(** comparison to zero *)
(****************************************************************************)

Definition lt_0 (x: word) : bool :=
  match Word.signed x with
    | Z0 => false
    | Zpos x' => false
    | Zneg x' => true
  end.

Definition ge_0 (x: word) : bool :=
  match Word.signed x with
    | Z0 => true
    | Zpos x' => true
    | Zneg x' => false
  end.

(****************************************************************************)
(** representation of nature numbers *)
(****************************************************************************)

Definition n0 := 0%nat.
Definition n1 := (S n0).
Definition n2 := (S n1).
Definition n3 := (S n2).
Definition n4 := (S n3).
Definition n5 := (S n4).
Definition n6 := (S n5).
Definition n7 := (S n6).
Definition n8 := (S n7).
Definition n9 := (S n8).
Definition n10 := (S n9).
Definition n11 := (S n10).
Definition n12 := (S n11).
Definition n13 := (S n12).
Definition n14 := (S n13).
Definition n15 := (S n14).
Definition n16 := (S n15).
Definition n17 := (S n16).
Definition n18 := (S n17).
Definition n19 := (S n18).
Definition n20 := (S n19).
Definition n21 := (S n20).
Definition n22 := (S n21).
Definition n23 := (S n22).
Definition n24 := (S n23).
Definition n25 := (S n24).
Definition n26 := (S n25).
Definition n27 := (S n26).
Definition n28 := (S n27).
Definition n29 := (S n28).
Definition n30 := (S n29).
Definition n31 := (S n30).
Definition n32 := (S n31).
Definition n47 := (S (n23 + n23)).
Definition n63 := (S (n31 + n31)).