Require Import FP.CoreData.
Require Import FP.CoreClasses.
Require Import FP.Classes.
Require Import FP.Data.Sum.
Require Import FP.Data.Prod.
Require Import FP.Data.Option.
Require Import FP.Data.Extend.
Require Import FP.Data.TwoThreeTrees.

Import CoreClassesNotation.
Import CoreDataNotation.
Import ClassesNotation.

Module TwoThreeTreesWF.
  Import TwoThreeTrees.

  Section Context.
    Context {K V:Type}
      `{! Lte K ,! Eqv K ,! ER_WF K ,! TotalOrd K
       ,! TotalOrdDec K ,! TotalOrd_RDC K
       ,! EqvDec K ,! Eqv_RDC K
       }.

    Inductive empty_tree : tree K V -> Prop :=
      | Empty_Null : empty_tree Null_t.
    Hint Constructors empty_tree.

    Inductive not_empty_tree : tree K V -> Prop :=
      | NotEmpty_Two : forall tl p tr, not_empty_tree (Two_t tl p tr)
      | NotEmtpy_Three : forall tl pl tm pr tr, not_empty_tree (Three_t tl pl tm pr tr).
    Hint Constructors not_empty_tree.

    Inductive in_tree : K -> tree K V -> Prop :=
      | In_TwoLeftTree :
          forall k tl pm tr, in_tree k tl -> in_tree k (Two_t tl pm tr)
      | In_TwoNode :
          forall k k' v tl tr, k ~= k' -> in_tree k (Two_t tl (k',v) tr)
      | In_TwoRightTree :
          forall k tl pm tr, in_tree k tr -> in_tree k (Two_t tl pm tr)
      | In_ThreeLeftTree :
          forall k tl pl tm pr tr, in_tree k tl -> in_tree k (Three_t tl pl tm pr tr)
      | In_ThreeLeftNode :
          forall k k' v tl tm pr tr, k ~= k' -> in_tree k (Three_t tl (k',v) tm pr tr)
      | In_ThreeMiddleTree :
          forall k tl pl tm pr tr, in_tree k tm -> in_tree k (Three_t tl pl tm pr tr)
      | In_ThreeRightNode :
          forall k k' v tl pl tm tr, k ~= k' -> in_tree k (Three_t tl pl tm (k',v) tr)
      | In_ThreeRightTree :
          forall k tl pl tm pr tr, in_tree k tr -> in_tree k (Three_t tl pl tm pr tr).
    Hint Constructors in_tree.

    Inductive maps_tree : K -> V -> tree K V -> Prop :=
      | Maps_TwoLeftTree :
          forall k v tl pm tr, maps_tree k v tl -> maps_tree k v (Two_t tl pm tr)
      | Maps_TwoNode :
          forall k k' v tl tr, k ~= k' -> maps_tree k v (Two_t tl (k',v) tr)
      | Maps_TwoRightTree :
          forall k v tl pm tr, maps_tree k v tr -> maps_tree k v (Two_t tl pm tr)
      | Maps_ThreeLeftTree :
          forall k v tl pl tm pr tr, maps_tree k v tl -> maps_tree k v (Three_t tl pl tm pr tr)
      | Maps_ThreeLeftNode :
          forall k k' v tl tm pr tr, k ~= k' -> maps_tree k v (Three_t tl (k',v) tm pr tr)
      | Maps_ThreeMiddleTree :
          forall k v tl pl tm pr tr, maps_tree k v tm -> maps_tree k v (Three_t tl pl tm pr tr)
      | Maps_ThreeRightNode :
          forall k k' v tl pl tm tr, k ~= k' -> maps_tree k v (Three_t tl pl tm (k',v) tr)
      | Maps_ThreeRightTree :
          forall k v tl pl tm pr tr, maps_tree k v tr -> maps_tree k v (Three_t tl pl tm pr tr).
    Hint Constructors maps_tree.

    Inductive not_in_tree : K -> tree K V -> Prop :=
      | NotIn_Null : forall k, not_in_tree k Null_t
      | NotIn_Two :
          forall k tl km vm tr,
          not_in_tree k tl
          -> k /~= km -> not_in_tree k tr
          -> not_in_tree k (Two_t tl (km,vm) tr)
      | NotIn_Three :
          forall k tl kl vl tm kr vr tr,
          not_in_tree k tl
          -> k /~= kl -> not_in_tree k tm
          -> k /~= kr -> not_in_tree k tr
          -> not_in_tree k (Three_t tl (kl,vl) tm (kr,vr) tr).
    Hint Constructors not_in_tree.

    Inductive bst_tree : extend K -> extend K -> tree K V -> Prop :=
      | BST_Null : forall l u, l <= u -> bst_tree l u Null_t
      | BST_Two :
          forall l_tl tl k v u_tr tr,
          bst_tree l_tl (Extend k) tl
          -> bst_tree (Extend k) u_tr tr
          -> bst_tree l_tl u_tr (Two_t tl (k,v) tr)
      | BST_Three :
          forall l_tl tl kl vl tm kr vr u_tr tr,
          bst_tree l_tl (Extend kl) tl
          -> bst_tree (Extend kl) (Extend kr) tm
          -> bst_tree (Extend kr) u_tr tr
          -> bst_tree l_tl u_tr (Three_t tl (kl,vl) tm (kr,vr) tr).
    Hint Constructors bst_tree.

    Inductive balance_tree : N -> tree K V -> Prop :=
      | Balance_Null : balance_tree 0 Null_t
      | Balance_Two :
          forall n tl p tr,
          balance_tree n tl
          -> balance_tree n tr
          -> balance_tree (n+1) (Two_t tl p tr)
      | Balance_Three :
          forall n tl pl tm pr tr,
          balance_tree n tl
          -> balance_tree n tm
          -> balance_tree n tr
          -> balance_tree (n+1) (Three_t tl pl tm pr tr).
    Hint Constructors balance_tree.

    Inductive in_context : K -> context K V -> Prop :=
      | In_TwoLeftHoleNode :
          forall k k' v tr c, k ~= k' -> in_context k (TwoLeftHole_c (k',v) tr c)
      | In_TwoLeftHoleTree :
          forall k pm tr c, in_tree k tr -> in_context k (TwoLeftHole_c pm tr c)
      | In_TwoLeftHoleContext :
          forall k pm tr c, in_context k c -> in_context k (TwoLeftHole_c pm tr c)
      | In_TwoRightHoleTree :
          forall k tl pm c, in_tree k tl -> in_context k (TwoRightHole_c tl pm c)
      | In_TwoRightHoleNode :
          forall k k' v tl c, k ~= k' -> in_context k (TwoRightHole_c tl (k',v) c)
      | In_TwoRightHoleContext :
          forall k tl pm c, in_context k c -> in_context k (TwoRightHole_c tl pm c)
      | In_ThreeLeftHoleLeftNode :
          forall k k' v tm pr tr c, k ~= k' -> in_context k (ThreeLeftHole_c (k',v) tm pr tr c)
      | In_ThreeLeftHoleMiddleTree :
          forall k pl tm pr tr c, in_tree k tm -> in_context k (ThreeLeftHole_c pl tm pr tr c)
      | In_ThreeLeftHoleRightNode :
          forall k k' v pl tm tr c, k ~= k' -> in_context k (ThreeLeftHole_c pl tm (k',v) tr c)
      | In_ThreeLeftHoleRightTree :
          forall k pl tm pr tr c, in_tree k tr -> in_context k (ThreeLeftHole_c pl tm pr tr c)
      | In_ThreeLeftHoleContext :
          forall k pl tm pr tr c, in_context k c -> in_context k (ThreeLeftHole_c pl tm pr tr c)
      | In_ThreeMiddleHoleLeftTree :
          forall k tl pl pr tr c, in_tree k tl -> in_context k (ThreeMiddleHole_c tl pl pr tr c)
      | In_ThreeMiddleHoleLeftNode :
          forall k k' v tl pr tr c, k ~= k' -> in_context k (ThreeMiddleHole_c tl (k',v) pr tr c)
      | In_ThreeMiddleHoleRightNode :
          forall k k' v tl pl tr c, k ~= k' -> in_context k (ThreeMiddleHole_c tl pl (k',v) tr c)
      | In_ThreeMiddleHoleRightTree :
          forall k tl pl pr tr c, in_tree k tr -> in_context k (ThreeMiddleHole_c tl pl pr tr c)
      | In_ThreeMiddleHoleContext :
          forall k tl pl pr tr c, in_context k c -> in_context k (ThreeMiddleHole_c tl pl pr tr c)
      | In_ThreeRightHoleLeftTree :
          forall k tl pl tm pr c, in_tree k tl -> in_context k (ThreeRightHole_c tl pl tm pr c)
      | In_ThreeRightHoleLeftNode :
          forall k k' v tl tm pr c, k ~= k' -> in_context k (ThreeRightHole_c tl (k',v) tm pr c)
      | In_ThreeRightHoleMiddleTree :
          forall k tl pl tm pr c, in_tree k tm -> in_context k (ThreeRightHole_c tl pl tm pr c)
      | In_ThreeRightHoleRightNode :
          forall k v tl pl tm c, in_context k (ThreeRightHole_c tl pl tm (k,v) c)
      | In_ThreeRightHoleContext :
          forall k tl pl tm pr c, in_context k c -> in_context k (ThreeRightHole_c tl pl tm pr c).
    Hint Constructors in_context.

    Inductive not_in_context : K -> context K V -> Prop :=
      | NotIn_Top : forall k, not_in_context k Top_c
      | NotIn_TwoLeftHole :
          forall k km vm tr c,
          k /~= km -> not_in_tree k tr
          -> not_in_context k c
          -> not_in_context k (TwoLeftHole_c (km,vm) tr c)
      | NotIn_TwoRightHole :
          forall k tl km vm c,
          not_in_tree k tl
          -> k /~= km -> not_in_context k c
          -> not_in_context k (TwoRightHole_c tl (km,vm) c)
      | NotIn_ThreeLeftHole :
          forall k kl vl tm kr vr tr c,
          k /~= kl -> not_in_tree k tm
          -> k /~= kr -> not_in_tree k tr
          -> not_in_context k c
          -> not_in_context k (ThreeLeftHole_c (kl,vl) tm (kr,vr) tr c)
      | NotIn_ThreeMiddleHole :
          forall k tl kl vl kr vr tr c,
          not_in_tree k tl
          -> k /~= kl
          -> k /~= kr -> not_in_tree k tr
          -> not_in_context k c
          -> not_in_context k (ThreeMiddleHole_c tl (kl,vl) (kr,vr) tr c)
      | NotIn_ThreeRightHole :
          forall k tl kl vl tm kr vr c,
          not_in_tree k tl
          -> k /~= kl -> not_in_tree k tm
          -> k /~= kr -> not_in_context k c
          -> not_in_context k (ThreeRightHole_c tl (kl,vl) tm (kr,vr) c).
    Hint Constructors not_in_context.

    Inductive maps_context : K -> V -> context K V -> Prop :=
      | Maps_TwoLeftHoleNode :
          forall k k' v tr c, k ~= k' -> maps_context k v (TwoLeftHole_c (k',v) tr c)
      | Maps_TwoLeftHoleTree :
          forall k v pm tr c, maps_tree k v tr -> maps_context k v (TwoLeftHole_c pm tr c)
      | Maps_TwoLeftHoleContext :
          forall k v pm tr c, maps_context k v c -> maps_context k v (TwoLeftHole_c pm tr c)
      | Maps_TwoRightHoleTree :
          forall k v tl pm c, maps_tree k v tl -> maps_context k v (TwoRightHole_c tl pm c)
      | Maps_TwoRightHoleNode :
          forall k k' v tl c, k ~= k' -> maps_context k v (TwoRightHole_c tl (k',v) c)
      | Maps_TwoRightHoleContext :
          forall k v tl pm c, maps_context k v c -> maps_context k v (TwoRightHole_c tl pm c)
      | Maps_ThreeLeftHoleLeftNode :
          forall k k' v tm pr tr c, k ~= k' -> maps_context k v (ThreeLeftHole_c (k',v) tm pr tr c)
      | Maps_ThreeLeftHoleMiddleTree :
          forall k v pl tm pr tr c, maps_tree k v tm -> maps_context k v (ThreeLeftHole_c pl tm pr tr c)
      | Maps_ThreeLeftHoleRightNode :
          forall k k' v pl tm tr c, k ~= k' -> maps_context k v (ThreeLeftHole_c pl tm (k',v) tr c)
      | Maps_ThreeLeftHoleRightTree :
          forall k v pl tm pr tr c, maps_tree k v tr -> maps_context k v (ThreeLeftHole_c pl tm pr tr c)
      | Maps_ThreeLeftHoleContext :
          forall k v pl tm pr tr c, maps_context k v c -> maps_context k v (ThreeLeftHole_c pl tm pr tr c)
      | Maps_ThreeMiddleHoleLeftTree :
          forall k v tl pl pr tr c, maps_tree k v tl -> maps_context k v (ThreeMiddleHole_c tl pl pr tr c)
      | Maps_ThreeMiddleHoleLeftNode :
          forall k k' v tl pr tr c, k ~= k' -> maps_context k v (ThreeMiddleHole_c tl (k',v) pr tr c)
      | Maps_ThreeMiddleHoleRightNode :
          forall k k' v tl pl tr c, k ~= k' -> maps_context k v (ThreeMiddleHole_c tl pl (k',v) tr c)
      | Maps_ThreeMiddleHoleRightTree :
          forall k v tl pl pr tr c, maps_tree k v tr -> maps_context k v (ThreeMiddleHole_c tl pl pr tr c)
      | Maps_ThreeMiddleHoleContext :
          forall k v tl pl pr tr c, maps_context k v c -> maps_context k v (ThreeMiddleHole_c tl pl pr tr c)
      | Maps_ThreeRightHoleLeftTree :
          forall k v tl pl tm pr c, maps_tree k v tl -> maps_context k v (ThreeRightHole_c tl pl tm pr c)
      | Maps_ThreeRightHoleLeftNode :
          forall k k' v tl tm pr c, k ~= k' -> maps_context k v (ThreeRightHole_c tl (k',v) tm pr c)
      | Maps_ThreeRightHoleMiddleTree :
          forall k v tl pl tm pr c, maps_tree k v tm -> maps_context k v (ThreeRightHole_c tl pl tm pr c)
      | Maps_ThreeRightHoleRightNode :
          forall k v tl pl tm c, maps_context k v (ThreeRightHole_c tl pl tm (k,v) c)
      | Maps_ThreeRightHoleContext :
          forall k v tl pl tm pr c, maps_context k v c -> maps_context k v (ThreeRightHole_c tl pl tm pr c).
    Hint Constructors maps_context.

    Inductive bst_context l_r u_r : extend K -> extend K -> context K V -> Prop :=
      | BST_Top : bst_context l_r u_r l_r u_r Top_c
      | BST_TwoLeftHole :
          forall l_c u_tr km vm tr c,
          bst_tree (Extend km) u_tr tr
          -> bst_context l_r u_r l_c u_tr c
          -> bst_context l_r u_r l_c (Extend km) (TwoLeftHole_c (km,vm) tr c)
      | BST_TwoRightHole :
          forall l_tl u_c tl km vm c,
          bst_tree l_tl (Extend km) tl
          -> bst_context l_r u_r l_tl u_c c
          -> bst_context l_r u_r (Extend km) u_c (TwoRightHole_c tl (km,vm) c)
      | BST_ThreeLeftHole :
          forall l_c u_tr kl vl tm kr vr tr c,
          bst_tree (Extend kl) (Extend kr) tm
          -> bst_tree (Extend kr) u_tr tr
          -> bst_context l_r u_r l_c u_tr c
          -> bst_context l_r u_r l_c (Extend kl) (ThreeLeftHole_c (kl,vl) tm (kr,vr) tr c)
      | BST_ThreeMiddleHole :
          forall l_tl u_tr tl kl vl kr vr tr c,
          bst_tree l_tl (Extend kl) tl
          -> bst_tree (Extend kr) u_tr tr
          -> bst_context l_r u_r l_tl u_tr c
          -> bst_context l_r u_r (Extend kl) (Extend kr) (ThreeMiddleHole_c tl (kl,vl) (kr,vr) tr c)
      | BST_ThreeRightHole :
          forall l_tl u_c tl kl vl tm kr vr c,
          bst_tree l_tl (Extend kl) tl
          -> bst_tree (Extend kl) (Extend kr) tm
          -> bst_context l_r u_r l_tl u_c c
          -> bst_context l_r u_r (Extend kr) u_c (ThreeRightHole_c tl (kl,vl) tm (kr,vr) c).
    Hint Constructors bst_context.

    Inductive balance_context : N -> N -> context K V -> Prop :=
      | Balance_Top : forall n, balance_context n n Top_c
      | Balance_TwoLeftHole :
          forall n n' pm tr c,
          balance_tree n tr
          -> balance_context (n+1) n' c
          -> balance_context n n' (TwoLeftHole_c pm tr c)
     | Balance_TwoRightHole :
         forall n n' tl pm c,
         balance_tree n tl
         -> balance_context (n+1) n' c
         -> balance_context n n' (TwoRightHole_c tl pm c)
     | Balance_ThreeLeftHole :
         forall n n' pl tm pr tr c,
         balance_tree n tm
         -> balance_tree n tr
         -> balance_context (n+1) n' c
         -> balance_context n n' (ThreeLeftHole_c pl tm pr tr c)
     | Balance_ThreeMiddleHole :
         forall n n' tl pl pr tr c,
         balance_tree n tl
         -> balance_tree n tr
         -> balance_context (n+1) n' c
         -> balance_context n n' (ThreeMiddleHole_c tl pl pr tr c)
     | Balance_ThreeRightHole :
         forall n n' tl pl tm pr c,
         balance_tree n tl
         -> balance_tree n tm
         -> balance_context (n+1) n' c
         -> balance_context n n' (ThreeRightHole_c tl pl tm pr c).
    Hint Constructors balance_context.

    Inductive in_location : K -> location K V -> Prop :=
      | In_LocTwoHoleLeftTree :
          forall k tl tr c, in_tree k tl -> in_location k (TwoHole_l tl tr c)
      | In_LocTwoHoleRightTree :
          forall k tl tr c, in_tree k tr -> in_location k (TwoHole_l tl tr c)
      | In_LocTwoHoleContext :
          forall k tl tr c, in_context k c -> in_location k (TwoHole_l tl tr c)
      | In_LocThreeLeftHoleLeftTree :
          forall k tl tm pr tr c, in_tree k tl -> in_location k (ThreeLeftHole_l tl tm pr tr c)
      | In_LocThreeLeftHoleMiddleTree :
          forall k tl tm pr tr c, in_tree k tm -> in_location k (ThreeLeftHole_l tl tm pr tr c)
      | In_LocThreeLeftHoleNode :
          forall k k' v tl tm tr c, k ~= k' -> in_location k (ThreeLeftHole_l tl tm (k',v) tr c)
      | In_LocThreeLeftHoleRightTree :
          forall k tl tm pr tr c, in_tree k tr -> in_location k (ThreeLeftHole_l tl tm pr tr c)
      | In_LocThreeLeftHoleContext :
          forall k tl tm pr tr c, in_context k c -> in_location k (ThreeLeftHole_l tl tm pr tr c)
      | In_LocThreeRightHoleLeftTree :
          forall k tl pl tm tr c, in_tree k tl -> in_location k (ThreeRightHole_l tl pl tm tr c)
      | In_LocThreeRightHoleNode :
          forall k k' v tl tm tr c, k ~= k' -> in_location k (ThreeRightHole_l tl (k',v) tm tr c)
      | In_LocThreeRightHoleMiddleTree :
          forall k tl pl tm tr c, in_tree k tm -> in_location k (ThreeRightHole_l tl pl tm tr c)
      | In_LocThreeRightHoleRightTree :
          forall k tl pl tm tr c, in_tree k tr -> in_location k (ThreeRightHole_l tl pl tm tr c)
      | In_LocThreeRightHoleContext :
          forall k tl pl tm tr c, in_context k c -> in_location k (ThreeRightHole_l tl pl tm tr c).
    Hint Constructors in_location.

    Inductive maps_location : K -> V -> location K V -> Prop :=
      | Maps_LocTwoHoleLeftTree :
          forall k v tl tr c, maps_tree k v tl -> maps_location k v (TwoHole_l tl tr c)
      | Maps_LocTwoHoleRightTree :
          forall k v tl tr c, maps_tree k v tr -> maps_location k v (TwoHole_l tl tr c)
      | Maps_LocTwoHoleContext :
          forall k v tl tr c, maps_context k v c -> maps_location k v (TwoHole_l tl tr c)
      | Maps_LocThreeLeftHoleLeftTree :
          forall k v tl tm pr tr c, maps_tree k v tl -> maps_location k v (ThreeLeftHole_l tl tm pr tr c)
      | Maps_LocThreeLeftHoleMiddleTree :
          forall k v tl tm pr tr c, maps_tree k v tm -> maps_location k v (ThreeLeftHole_l tl tm pr tr c)
      | Maps_LocThreeLeftHoleNode :
          forall k k' v tl tm tr c, k ~= k' -> maps_location k v (ThreeLeftHole_l tl tm (k',v) tr c)
      | Maps_LocThreeLeftHoleRightTree :
          forall k v tl tm pr tr c, maps_tree k v tr -> maps_location k v (ThreeLeftHole_l tl tm pr tr c)
      | Maps_LocThreeLeftHoleContext :
          forall k v tl tm pr tr c, maps_context k v c -> maps_location k v (ThreeLeftHole_l tl tm pr tr c)
      | Maps_LocThreeRightHoleLeftTree :
          forall k v tl pl tm tr c, maps_tree k v tl -> maps_location k v (ThreeRightHole_l tl pl tm tr c)
      | Maps_LocThreeRightHoleNode :
          forall k k' v tl tm tr c, k ~= k' -> maps_location k v (ThreeRightHole_l tl (k',v) tm tr c)
      | Maps_LocThreeRightHoleMiddleTree :
          forall k v tl pl tm tr c, maps_tree k v tm -> maps_location k v (ThreeRightHole_l tl pl tm tr c)
      | Maps_LocThreeRightHoleRightTree :
          forall k v tl pl tm tr c, maps_tree k v tr -> maps_location k v (ThreeRightHole_l tl pl tm tr c)
      | Maps_LocThreeRightHoleContext :
          forall k v tl pl tm tr c, maps_context k v c -> maps_location k v (ThreeRightHole_l tl pl tm tr c).
    Hint Constructors maps_location.

    Inductive not_in_location : K -> location K V -> Prop :=
      | NotIn_TwoNode :
          forall k tl tr c,
          not_in_tree k tl
          -> not_in_tree k tr
          -> not_in_context k c
          -> not_in_location k (TwoHole_l tl tr c)
      | NotIn_ThreeLeftNode :
          forall k tl tm kr vr tr c,
          not_in_tree k tl
          -> not_in_tree k tm
          -> k /~= kr -> not_in_tree k tr
          -> not_in_context k c
          -> not_in_location k (ThreeLeftHole_l tl tm (kr,vr) tr c)
      | NotIn_ThreeRightNode :
          forall k tl kl vl tm tr c,
          not_in_tree k tl
          -> k /~= kl -> not_in_tree k tm
          -> not_in_tree k tr
          -> not_in_context k c
          -> not_in_location k (ThreeRightHole_l tl (kl,vl) tm  tr c).
    Hint Constructors not_in_location.

    Inductive bst_location l_r u_r : extend K -> location K V -> Prop :=
      | BST_TwoHole :
          forall kM l_c u_c tl tr c,
          bst_tree l_c kM tl
          -> bst_tree kM u_c tr
          -> bst_context l_r u_r l_c u_c c
          -> bst_location l_r u_r kM (TwoHole_l tl tr c)
      | BST_ThreeLeftNodeHole :
          forall kM l_c u_c tl tm kr vr tr c,
          bst_tree l_c kM tl
          -> bst_tree kM (Extend kr) tm
          -> bst_tree (Extend kr) u_c tr
          -> bst_context l_r u_r l_c u_c c
          -> bst_location l_r u_r kM (ThreeLeftHole_l tl tm (kr,vr) tr c)
      | BST_ThreeRightNodeHole :
          forall kM l_c u_c tl kl vl tm tr c,
          bst_tree l_c (Extend kl) tl
          -> bst_tree (Extend kl) kM tm
          -> bst_tree kM u_c tr
          -> bst_context l_r u_r l_c u_c c
          -> bst_location l_r u_r kM (ThreeRightHole_l tl (kl,vl) tm tr c).
    Hint Constructors bst_location.

    Inductive balance_location : N -> location K V -> Prop :=
      | Balance_TwoHole :
          forall n tl tr n' c,
          balance_tree n tl
          -> balance_tree n tr
          -> balance_context (n+1) n' c
          -> balance_location n' (TwoHole_l tl tr c)
      | Balance_ThreeLeftNodeHole :
          forall n tl tm pr tr n' c,
          balance_tree n tl
          -> balance_tree n tm
          -> balance_tree n tr
          -> balance_context (n+1) n' c
          -> balance_location n' (ThreeLeftHole_l tl tm pr tr c)
      | Balance_ThreeRightNodeHole :
          forall n tl pl tm tr n' c,
          balance_tree n tl
          -> balance_tree n tm
          -> balance_tree n tr
          -> balance_context (n+1) n' c
          -> balance_location n' (ThreeRightHole_l tl pl tm tr c).

    Local Ltac gd x := generalize dependent x.

    Lemma plus_one_elim : forall {x y}, x+1 = y+1 -> x=y.
    Proof.
      intros.
      assert (1+x=y+1).
      { transitivity (x+1) ; auto.
        symmetry.
        apply (BinNat.N.add_comm x 1).
      }
      assert (1+x=1+y).
      { transitivity (y+1) ; auto.
        apply (BinNat.N.add_comm y 1).
      }
      exact (BinNat.Nplus_reg_l 1 x y H1).
    Qed.
    Hint Immediate plus_one_elim.

    Lemma plus_one_not_zero_l : forall {n}, 0 = n+1 -> False.
    Admitted.
    (*
    Proof.
      intros n Heq ; destruct n ; unfold "+" in * ; simpl in * ; discriminate Heq.
    Qed.
    *)

    Lemma plus_one_not_zero_r : forall {n}, n+1 = 0 -> False.
    Admitted.
    (*
    Proof.
      intros n H ; symmetry in H ; eauto.
    Qed.
    *)

    Lemma lt_eqv_contradiction : forall {x y}, x < y -> x /~= y.
    Admitted.
    (*
    Proof.
      intros x y Hlt Heqv ; apply Hlt ; refine (PartialOrd_respect_eqv y y _ y x _ _)
      ; try reflexivity ; symmetry ; auto.
    Qed.
    *)
    Hint Immediate lt_eqv_contradiction.

    Lemma lt_eqv_contradiction' : forall {x y}, x < y -> y /~= x.
    Admitted.
    (*
    Proof.
      intros x y Hlt Heqv ; apply Hlt ; refine (PartialOrd_respect_eqv y y _ y x _ _)
      ; try reflexivity ; auto.
    Qed.
    *)
    Hint Immediate lt_eqv_contradiction'.

    Ltac mysimp := fail.
    Hint Extern 0 => mysimp.

    Ltac mysimp0 :=
      match goal with
      (* basic rules *)
      | [ |- and _ _ ] => constructor
      | [ |- ~ _ ] => unfold "~" at 1 ; intros

      | [ H : and _ _ |- _ ] => destruct H
      | [ H : exists _, _ |- _ ] => destruct H
      | [ H : ?x /\ _ |- _ ] => match type of x with Prop => destruct H | _ => fail end
      | [ H : _ <-> _ |- _ ] => destruct H
      | [ H1 : ?X , H2 : ?X -> exists _, _ |- _ ] => specialize (H2 H1) ; destruct H2
      | [ H : false = _ ~=! _ |- _ ] => symmetry in H ; apply neg_dec_correct in H
      | [ H : true = _ ~=! _ |- _ ] => symmetry in H ; apply dec_correct in H
      | [ H : Lt = _ <=>! _ |- _ ] => symmetry in H ; apply tord_dec_correct_lt in H
      | [ H : Eq = _ <=>! _ |- _ ] => symmetry in H ; apply tord_dec_correct_eqv in H
      | [ H : Gt = _ <=>! _ |- _ ] => symmetry in H ; apply tord_dec_correct_gt in H
      | [ H : ?x+1 = ?y+1 |- _ ] => apply plus_one_elim in H ; subst x
      | [ H : 0 = _ + 1 |- _ ] => exfalso ; apply (plus_one_not_zero_l H)
      | [ H : _ + 1 = 0 |- _ ] => exfalso ; apply (plus_one_not_zero_r H)
      | [ H : None = None |- _ ] => clear H
      | [ H : Some _ = Some _ |- _ ] => injection H ; intros ; subst ; clear H
      | [ H1 : ?X -> ~?Y , H2 : ?X , H3 : ?Y |- _ ] => exfalso ; apply (H1 H2 H3)

      (* tree rules *)
      | [ |- not_in_tree _ (Two_t _ (_,_) _) ] => fail 1
      | [ |- not_in_tree _ (Two_t _ ?p _) ] => destruct p
      | [ |- not_in_tree _ (Three_t _ (_,_) _ (_,_) _) ] => fail 1
      | [ |- not_in_tree _ (Three_t _ ?p _ (_,_) _) ] => destruct p
      | [ |- not_in_tree _ (Three_t _ (_,_) _ ?p _) ] => destruct p
      | [ |- not_in_tree _ (Three_t _ ?pl _ ?pr _) ] => destruct pl,pr

      | [ H : in_tree _ Null_t |- _ ] => inversion H
      | [ H : maps_tree _ _ Null_t |- _ ] => inversion H
      | [ H : in_context _ Top_c |- _ ] => inversion H

      | [ H : empty_tree _ |- _ ] => inversion H ; subst ; clear H
      | [ H : not_in_tree _ Null_t |- _ ] => inversion H ; subst ; clear H
      | [ H : not_in_tree _ (Two_t _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : not_in_tree _ (Three_t _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_tree _ _ Null_t |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_tree _ _ (Two_t _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_tree _ _ (Three_t _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_tree _ Null_t |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_tree _ (Two_t _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_tree _ (Three_t _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_tree 0 _ |- _ ] => inversion H ; subst ; clear H ; try mysimp
      | [ H : in_context _ _ _ _ (ThreeLeftHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ _ _ _ (ThreeMiddleHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ _ _ _ (ThreeRightHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_context _ _ _ _ Top_c |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_context _ _ _ _ (TwoLeftHole_c _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_context _ _ _ _ (TwoRightHole_c _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_context _ _ _ _ (ThreeLeftHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_context _ _ _ _ (ThreeMiddleHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_context _ _ _ _ (ThreeRightHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_context _ _ Top_c |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_context _ _ (TwoLeftHole_c _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_context _ _ (TwoRightHole_c _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_context _ _ (ThreeLeftHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_context _ _ (ThreeMiddleHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_context _ _ (ThreeRightHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_location _ _ _ (TwoHole_l _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_location _ _ _ (ThreeLeftHole_l _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : bst_location _ _ _ (ThreeRightHole_l _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_location _ (TwoHole_l _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_location _ (ThreeLeftHole_l _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : balance_location _ (ThreeRightHole_l _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      end.
    Ltac mysimp ::= mysimp0.

    Local Ltac rip :=
      match goal with
      (* basic rules *)
      | [ H : or _ _ |- _ ] => inversion H ; subst ; clear H

      (* tree rules *)
      | [ H : in_tree _ (Two_t _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_tree _ (Three_t _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : maps_tree _ _ (Two_t _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : maps_tree _ _ (Three_t _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ (TwoLeftHole_c _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ (TwoRightHole_c _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ (ThreeLeftHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ (ThreeMiddleHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      | [ H : in_context _ (ThreeRightHole_c _ _ _ _ _) |- _ ] => inversion H ; subst ; clear H
      end.

    Ltac flip_eqn x :=
      match goal with
      | [ H : _ = ?E |- _ ] => match E with context [ x ] => symmetry in H end
      end.

    Ltac let_pair_drill :=
      match goal with
      | [ |- context [ let (_,_) := ?p in _ ] ] => destruct p
      | [ H : context [ let (_,_) := ?p in _ ] |- _ ] => destruct p
      end.

    Ltac tord_drill :=
      match goal with
      | [ |- context [?x <=>! ?y] ] =>
          let m := fresh "tord" in remember (x <=>! y) as m ; destruct m
      end.

    Ltac atom_match_drill :=
      match goal with
      | [ |- context [ match ?X with _ => _ end ] ] =>
          match X with (?f _) => fail 1 | _ => destruct X end
      | [ H : context [ match ?X with _ => _ end ] |- _ ] =>
          match X with (?f _) => fail 1 | _ => destruct X end
      end.

    Lemma null_bst_lib : forall {m}, bst_tree m m Null_t.
    Admitted.
    (*
    Proof.
      intros ; econstructor ; reflexivity.
    Qed.
    *)
    Hint Immediate null_bst_lib.

    Lemma empty_balance_zero : forall {t}, empty_tree t -> balance_tree 0 t.
    Proof.
      intros t H ; inversion H ; eauto.
    Qed.
    Hint Resolve empty_balance_zero.

    Lemma balance_tree_unique : forall {n n' t}, balance_tree n t -> balance_tree n' t -> n = n'.
    Proof.
      intros n n' t ; gd n' ; gd n ; induction t ; intros ; repeat mysimp || rip ; eauto.
      rewrite (IHt1 _ _ H3 H4) ; auto.
      rewrite (IHt1 _ _ H4 H5) ; auto.
    Qed.
    Ltac balance_tree_unique_zero :=
      match goal with
      | [ Hemp : empty_tree ?t , Hbal : balance_tree ?n ?t |- _ ] =>
          match n with
          | 0 => fail 1
          | _ => assert (n = 0) ; [ eapply (balance_tree_unique Hbal) ; clear Hbal | subst ]
          end
      end.
    Ltac mysimp1 := mysimp0 || balance_tree_unique_zero.
    Ltac mysimp ::= mysimp1.

    Lemma balance_tree_two_right_matches_left :
      forall {n tl tr n' c},
      balance_tree n tl -> balance_location n' (TwoHole_l tl tr c) -> balance_tree n tr.
    Proof.
      intros. inversion H0 ; subst ; clear H0.
      rewrite (balance_tree_unique H H5) ; auto.
    Qed.

    Lemma maps_to_in : forall {k t v}, maps_tree k v t -> in_tree k t.
    Admitted.
    (*
    Proof.
      intros k t v H ; induction t ; repeat mysimp || rip ; eauto.
    Qed.
    *)
    Hint Resolve maps_to_in.

    Lemma in_to_maps_ex : forall {k t}, in_tree k t -> exists v, maps_tree k v t.
    Admitted.
    (*
    Proof.
      intros k t H ; induction t ; repeat mysimp || rip ; eauto.
    Qed.
    *)

    Lemma not_in_to_neg_in_tree : forall k t, not_in_tree k t <-> ~in_tree k t.
    Admitted.
    (*
    Proof. intros ; induction t ; constructor ; intros ; repeat mysimp || rip ; eauto.  Qed.
    *)

    Lemma in_tree_dp : forall k t, in_tree k t \/ not_in_tree k t.
    Admitted.
    (*
    Proof.
      intros k t ; induction t ; repeat mysimp || rip || auto ; eauto.
      - destruct p as [k' v].
        remember (k <=>! k') as m ; destruct m ; repeat mysimp ; eauto
        ; right ; repeat mysimp || rip || auto ; eauto.
      - destruct p as [k' v], p0 as [k0' v0].
        remember (k <=>! k') as m ; destruct m ; repeat mysimp ; eauto
        ; remember (k <=>! k0') as m ; destruct m ; repeat mysimp ; eauto
        ; right ; repeat mysimp || rip || auto ; eauto.
    Qed.
    *)

    Lemma empty_tree_dp : forall t, empty_tree t \/ not_empty_tree t.
    Proof. intros t ; destruct t ; eauto. Qed.

    Ltac in_tree_case k t :=
      let Hin := fresh "Hin" in
      let Hmaps := fresh "Hmaps" in
      let Hnotin := fresh "Hnotin" in
      let v := fresh "v" in
      destruct (in_tree_dp k t) as [Hin | Hnotin]
      ; [apply in_to_maps_ex in Hin ; destruct Hin as [v Hmaps]|].

    Lemma bst_tree_weaken :
      forall l_t l_t' u_t u_t' t,
      bst_tree l_t u_t t -> l_t' <= l_t -> u_t' >= u_t -> bst_tree l_t' u_t' t.
    Admitted.
    Hint Immediate bst_tree_weaken.

    (* Lemmas about single *)

    (*
    Lemma single_maps :
      forall {k k' v},
      k ~= k'
      -> maps_tree k v (single (k',v)).
    Admitted.
    Hint Resolve single_maps.

    Lemma single_not_in :
      forall {k k' v},
      k /~= k'
      -> not_in_tree k (single (k',v)).
    Admitted.
    Hint Resolve single_not_in.
    *)

    (* Lemmas about zip *)

    (*
    Lemma zip_maps_intro :
      forall {k v t c},
      maps_tree k v t \/ maps_context k v c
      -> maps_tree k v (zip t c).
    Admitted.
    Hint Resolve zip_maps_intro.

    Lemma zip_maps_elim_t :
      forall {k v t c},
      maps_tree k v (zip t c)
      -> not_in_tree k t
      -> maps_context k v c.
    Admitted.
    Hint Resolve zip_maps_elim_t.

    Lemma zip_maps_elim_c :
      forall {k v t c},
      maps_tree k v (zip t c)
      -> not_in_context k c
      -> maps_tree k v t.
    Admitted.
    Hint Resolve zip_maps_elim_c.

    Lemma zip_not_in_intro :
      forall {k t c},
      not_in_tree k t
      -> not_in_context k c
      -> not_in_tree k (zip t c).
    Admitted.
    Hint Resolve zip_not_in_intro.

    Lemma zip_not_in_elim_t :
      forall {k t c},
      not_in_tree k (zip t c)
      -> not_in_tree k t.
    Admitted.
    Hint Resolve zip_not_in_elim_t.

    Lemma zip_not_in_elim_c :
      forall {k t c},
      not_in_tree k (zip t c)
      -> not_in_context k c.
    Admitted.
    Hint Resolve zip_not_in_elim_c.

    Lemma zip_bst :
      forall {l_t u_t t l_r u_r c},
      bst_tree l_t u_t t
      -> bst_context l_r u_r l_t u_t c
      -> bst_tree l_r u_r (zip t c).
    Admitted.
    Hint Resolve zip_bst.

    Lemma zip_balance :
      forall {n t n' c},
      balance_tree n t
      -> balance_context n n' c
      -> balance_tree n' (zip t c).
    Admitted.
    Hint Resolve zip_balance.
    *)

    (* Lemmas about fuse *)

    Lemma fuse_maps_intro :
      forall {k v c c'},
      maps_context k v c \/ maps_context k v c'
      -> maps_context k v (fuse c c').
    Admitted.
    Hint Resolve fuse_maps_intro.

    (*
    Lemma fuse_maps_elim_c :
      forall {k v c c'},
      maps_context k v (fuse c c')
      -> not_in_context k c'
      -> in_context k c.
    Admitted.
    Hint Resolve fuse_maps_elim_c.

    Lemma fuse_maps_elim_c' :
      forall {k v c c'},
      maps_context k v (fuse c c')
      -> not_in_context k c
      -> in_context k c'.
    Admitted.
    Hint Resolve fuse_maps_elim_c'.

    Lemma fuse_not_in_intro :
      forall {k c c'},
      not_in_context k c
      -> not_in_context k c'
      -> not_in_context k (fuse c c').
    Admitted.
    Hint Resolve fuse_not_in_intro.

    Lemma fuse_not_in_elim_c :
      forall {k c c'},
      not_in_context k (fuse c c')
      -> not_in_context k c.
    Admitted.
    Hint Resolve fuse_not_in_elim_c.

    Lemma fuse_not_in_elim_c' :
      forall {k c c'},
      not_in_context k (fuse c c')
      -> not_in_context k c'.
    Admitted.
    Hint Resolve fuse_not_in_elim_c'.
    *)

    Lemma fuse_bst :
      forall {l_m u_m l_t u_t c l_r u_r c'},
      bst_context l_m u_m l_t u_t c
      -> bst_context l_r u_r l_m u_m c'
      -> bst_context l_r u_r l_t u_t (fuse c c').
    Admitted.
    Hint Resolve fuse_bst.

    Lemma fuse_balance :
      forall {n n' c n'' c'},
      balance_context n n' c
      -> balance_context n' n'' c'
      -> balance_context n n'' (fuse c c').
    Admitted.
    Hint Resolve fuse_balance.

    (* Lemmas about locate. *)

    Lemma locate_fail_eq :
      forall {k t} c, not_in_tree k t -> exists c', locate k t c = inl c'.
    Admitted.

    Lemma locate_success_eq :
      forall {k v t} c, maps_tree k v t -> exists l, locate k t c = inr (v,l).
    Admitted.

    Ltac locate_match_progress :=
      let Hex := fresh "Hex" in let c'  := fresh "c'"  in
      let l   := fresh "l"   in let Heq := fresh "Heq" in
      match goal with
      | [ |- context [ match locate ?k ?t ?c with _ => _ end ] ] =>
          match goal with
          | [ H : not_in_tree k t |- _ ] =>
              assert (exists c', locate k t c = inl c') as Hex
              ; [ eapply locate_fail_eq | destruct Hex as [c' Heq] ; rewrite Heq ]
          | [ H : maps_tree k ?v t |- _ ] =>
              assert (exists l, locate k t c = inr (v,l)) as Hex
              ; [ eapply locate_success_eq
                | destruct Hex as [l Heq] ; rewrite Heq
                ]
          | _ => in_tree_case k t ; locate_match_progress
          end
      | [ Hm : context [ match locate ?k ?t ?c with _ => _ end ] |- _ ] =>
          match goal with
          | [ H : not_in_tree k t |- _ ] =>
              assert (exists c', locate k t c = inl c') as Hex
              ; [ clear Hm ; eapply locate_fail_eq
                | destruct Hex as [c' Heq] ; rewrite Heq in Hm
                ]
          | [ H : maps_tree k ?v t |- _ ] =>
              assert (exists l, locate k t c = inr (v,l)) as Hex
              ; [ clear Hm ; eapply locate_success_eq
                | destruct Hex as [l Heq] ; rewrite Heq in Hm
                ]
          | _ => in_tree_case k t ; locate_match_progress
          end
      end.

    Lemma locate_fail_maps_intro :
      forall {k v k' t c c'},
      locate k' t c = inl c'
      -> maps_tree k v t \/ maps_context k v c
      -> maps_context k v c'.
    Admitted.
    Hint Resolve locate_fail_maps_intro.

    Lemma locate_fail_maps_elim_t :
      forall {k v k' t c c'},
      locate k' t c = inl c'
      -> maps_context k v c'
      -> not_in_context k c
      -> maps_tree k v t.
    Admitted.
    Hint Resolve locate_fail_maps_elim_t.

    Lemma locate_fail_maps_elim_c :
      forall {k v k' t c c'},
      locate k' t c = inl c'
      -> maps_context k v c'
      -> not_in_tree k t
      -> maps_context k v c.
    Admitted.
    Hint Resolve locate_fail_maps_elim_c.

    Lemma locate_fail_not_in_intro :
      forall {k t c c'},
      locate k t c = inl c'
      -> not_in_tree k t
      -> not_in_context k c
      -> not_in_context k c'.
    Admitted.
    Hint Resolve locate_fail_not_in_intro.

    (*

    Lemma locate_fail_not_in_elim_t :
      forall {k t c c'},
      locate k t c = inl c'
      -> not_in_context k c'
      -> not_in_tree k t.
    Admitted.
    Hint Resolve locate_fail_not_in_elim_t.

    Lemma locate_fail_not_in_elim_c :
      forall {k t c c'},
      locate k t c = inl c'
      -> not_in_context k c'
      -> not_in_context k c.
    Admitted.
    Hint Resolve locate_fail_not_in_elim_c.

    *)
    Lemma locate_success_not_in_k :
      forall {k t c v l},
      locate k t c = inr (v,l)
      -> not_in_location k l.
    Admitted.
    Hint Resolve locate_success_not_in_k.
    (*

    Ltac pose_locate_success_not_in_k :=
      let Hnotin := fresh "Hnotin" in let n := fresh "n" in
      let finish Heq k l :=
        assert (not_in_location k l) as Hnotin
        ; [ eapply (locate_success_not_in_k Heq) ; clear Heq
          | inversion Hnotin ; subst ; clear Hnotin
          ]
      in
      match goal with
      | [ Heq : locate ?k ?t ?c = inr (_,TwoHole_l ?tl ?tr ?c') |- _ ] =>
          match goal with
          | [ Hbal : not_in_tree k tl |- _ ] => fail 1
          | _ => finish Heq k (TwoHole_l tl tr c')
          end
      | [ Heq : locate ?k ?t ?c = inr (_,ThreeLeftHole_l ?tl ?tm ?pr ?tr ?c') |- _ ] =>
          match goal with
          | [ Hbal : not_in_tree k tl |- _ ] => fail 1
          | _ => finish Heq k (ThreeLeftHole_l tl tm pr tr c')
          end
      | [ Heq : locate ?k ?t ?c = inr (_,ThreeRightHole_l ?tl ?pl ?tm ?tr ?c') |- _ ] =>
          match goal with
          | [ Hbal : not_in_tree k tl |- _ ] => fail 1
          | _ => finish Heq k (ThreeRightHole_l tl pl tm tr c')
          end
      end.
    *)

    Lemma locate_success_maps_intro :
      forall {k v k' v' t c l},
      locate k' t c = inr (v',l)
      -> k /~= k'
      -> maps_tree k v t \/ maps_context k v c
      -> maps_location k v l.
    Admitted.
    Hint Resolve locate_success_maps_intro.

    Lemma locate_success_maps_intro_two_c :
      forall {k v k' v' t c tl tr c'},
      locate k' t c = inr (v',TwoHole_l tl tr c')
      -> k /~= k'
      -> maps_tree k v t \/ maps_context k v c
      -> not_in_tree k tl
      -> not_in_tree k tr
      -> maps_context k v c'.
    Admitted.
    Hint Resolve locate_success_maps_intro_two_c.

    (*
    Ltac pose_locate_success_maps_intro :=
      let Hmaps := fresh "Hmaps" in
      let finish Heq k v l :=
        assert (maps_location k v l) as Hmaps
        ; [ eapply (locate_success_maps_intro Heq) ; clear Heq
          | inversion Hmaps ; subst ; clear Hmaps ]
      in
      match goal with
      | [ H : maps_tree ?k ?v ?t , Hneq : ?k /~= ?k' , Heq : locate ?k' ?t _ = inr (_,?l) |- _ ] =>
          match l with
          | TwoHole_l ?tl ?tr ?c' =>
              match goal with
              | [ H : maps_tree k v tl |- _ ] => fail 1
              | [ H : maps_tree k v tr |- _ ] => fail 1
              | [ H : maps_context k v c' |- _ ] => fail 1
              | _ => finish Heq k v l
          | ThreeLeftHole_l ?tl ?tm ?pr ?tr ?c' =>
              | [ H :
            finish Heq c' k v l
          | ThreeRightHole_l ?tl ?pl ?tm ?tr ?c' => finish Heq c' k v l
          end
      end.
    *)

    Lemma locate_success_maps_elim_t :
      forall {k v k' v' t c l},
      locate k' t c = inr (v',l)
      -> k /~= k'
      -> maps_location k v l
      -> not_in_context k c
      -> maps_tree k v t.
    Admitted.
    Hint Resolve locate_success_maps_elim_t.

    Lemma locate_success_maps_elim_c :
      forall {k v k' v' t c l},
      locate k' t c = inr (v',l)
      -> k /~= k'
      -> maps_location k v l
      -> not_in_tree k t
      -> maps_context k v c.
    Admitted.
    Hint Resolve locate_success_maps_elim_c.

    Lemma locate_fail_bst_ex :
      forall {k l_t u_t t l_r u_r c c'},
      locate k t c = inl c'
      -> not_in_tree k t
      -> bst_tree l_t u_t t
      -> bst_context l_r u_r l_t u_t c
      -> exists l u, bst_context l_r u_r l u c' /\ l <= Extend k <= u.
    Admitted.

    Lemma locate_fail_bst_top_ex :
      forall {k l_t u_t t c'},
      locate k t Top_c = inl c'
      -> not_in_tree k t
      -> bst_tree l_t u_t t
      -> exists l u, bst_context l_t u_t l u c' /\ l <= Extend k <= u.
    Admitted.

    Ltac pose_locate_fail_bst_top_ex :=
      match goal with
      | [ H : bst_tree ?l_t ?u_t ?t , Heq : locate ?k ?t Top_c = inl ?c' |- _] =>
          match goal with
          | [ H : bst_context _ _ _ _ c' |- _ ] => fail 1
          | _ =>
            let Hex := fresh "Hex" in let l := fresh "l" in let u := fresh "u" in
            assert (exists l u, bst_context l_t u_t l u c' /\ l <= Extend k <= u) as Hex
            ; [ eapply (locate_fail_bst_ex Heq) ; clear Heq
              | destruct Hex as [l Hex] ; destruct Hex as [u Hex] ; destruct Hex
              ]
          end
      end.

    Lemma locate_success_bst :
      forall {k l_t u_t t l_r u_r c v l},
      locate k t c = inr (v,l)
      -> maps_tree k v t
      -> bst_tree l_t u_t t
      -> bst_context l_r u_r l_t u_t c
      -> bst_location l_r u_r (Extend k) l.
    Admitted.
    Hint Resolve locate_success_bst.

    Lemma locate_fail_balance :
      forall {k n t n' c c'},
      locate k t c = inl c'
      -> not_in_tree k t
      -> balance_tree n t
      -> balance_context n n' c
      -> balance_context 0 n' c'.
    Admitted.
    Hint Resolve locate_fail_balance.

    Lemma locate_success_balance :
      forall {k n t n' c v l},
      locate k t c = inr (v,l)
      -> maps_tree k v t
      -> balance_tree n t
      -> balance_context n n' c
      -> balance_location n' l.
    Admitted.
    Hint Resolve locate_success_balance.

    Ltac pose_locate_success_balance :=
      let Hex := fresh "Hex" in let Hbal := fresh "Hbal" in let n := fresh "n" in
      let finish Heq c' l :=
        match goal with
        | [ Hbal : balance_context _ _ c' |- _ ] => fail 1
        | _ => assert (exists n, balance_location n l) as Hex
               ; [ econstructor ; eapply (locate_success_balance Heq) ; clear Heq
                 | destruct Hex as [n Hbal] ; inversion Hbal ; subst ; clear Hbal ]
        end
      in
      match goal with
      | [ Heq : locate _ _ _ = inr (_,?l) |- _ ] =>
          match l with
          | TwoHole_l _ _ ?c' => finish Heq c' l
          | ThreeLeftHole_l _ _ _ _ ?c' => finish Heq c' l
          | ThreeRightHole_l _ _ _ _ ?c' => finish Heq c' l
          end
      end.

    (* Lemmas about lookup. *)

    Lemma lookup_success_eq : forall {k v t}, maps_tree k v t -> lookup k t = Some v.
    Admitted.
    (*
    Proof. intros k v t Ht ; unfold lookup ; locate_match_progress ; eauto. Qed.
    *)

    Program Definition lookup_total k t (Ht:in_tree k t) : V :=
      match lookup k t with
      | None => False_rect _ _
      | Some v => v
      end.
    Next Obligation.
      destruct (in_to_maps_ex Ht) as [v Hmaps] ; rewrite (lookup_success_eq Hmaps) in * ; congruence.
    Qed.

    (* Lemmas about fill_location *)

    Lemma fill_location_maps_k :
      forall {k v l},
      not_in_location k l
      -> maps_tree k v (fill_location (k,v) l).
    Admitted.
    Hint Resolve fill_location_maps_k.

    Lemma fill_location_maps_intro :
      forall {k k' v v' v'' t c l},
      locate k' t c = inr (v',l)
      -> k /~= k'
      -> maps_tree k v t \/ maps_context k v c
      -> maps_tree k v (fill_location (k',v'') l).
    Admitted.
    Hint Resolve fill_location_maps_intro.

    Lemma fill_location_maps_elim_t :
      forall {k k' v v' v'' t c l},
      locate k' t c = inr (v',l)
      -> k /~= k'
      -> maps_tree k v (fill_location (k',v'') l)
      -> not_in_context k c
      -> maps_tree k v t.
    Admitted.
    Hint Resolve fill_location_maps_elim_t.

    Lemma fill_location_maps_elim_c :
      forall {k k' v v' v'' t c l},
      locate k' t c = inr (v',l)
      -> k /~= k'
      -> maps_tree k v (fill_location (k',v'') l)
      -> not_in_tree k t
      -> maps_context k v c.
    Admitted.
    Hint Resolve fill_location_maps_elim_c.

    Lemma fill_location_bst :
      forall {k v l_r u_r l},
      bst_location l_r u_r (Extend k) l
      -> bst_tree l_r u_r (fill_location (k,v) l).
    Admitted.
    Hint Resolve fill_location_bst.

    Lemma fill_location_balance :
      forall {k v n l},
      balance_location n l
      -> balance_tree n (fill_location (k,v) l).
    Admitted.
    Hint Resolve fill_location_balance.

    (* Lemmas about locate_greatest *)

    Lemma locate_greatest_fail_eq : forall {t c}, empty_tree t -> locate_greatest t c = None.
    Admitted.

    Lemma locate_greatest_success_eq :
      forall {t c}, not_empty_tree t -> exists k v lM, locate_greatest t c = Some ((k,v),lM).
    Admitted.

    Ltac locate_greatest_match_progress :=
      let Hex := fresh "Hex" in let k   := fresh "k'"  in let v := fresh "v'" in
      let lM  := fresh "lM'" in let Heq := fresh "Heq" in
      match goal with
      | [ |- context [ match locate_greatest ?t ?c with _ => _ end ] ] =>
          match goal with
          | [ H : empty_tree t |- _ ] =>
              assert (locate_greatest t c = None) as Heq
              ; [ eapply locate_greatest_fail_eq | rewrite Heq ]
          | [ H : not_empty_tree t |- _ ] =>
              assert (exists k v lM, locate_greatest t c = Some ((k,v),lM)) as Hex
              ; [ eapply locate_greatest_success_eq
                | destruct Hex as [k Hex] ; destruct Hex as [v Hex]
                  ; destruct Hex as [lM Heq] ; rewrite Heq ]
          | _ => destruct (empty_tree_dp t) ; locate_greatest_match_progress
          end
      | [ Hm : context [ match locate_greatest ?t ?c with _ => _ end ] |- _ ] =>
          match goal with
          | [ H : empty_tree t |- _ ] =>
              assert (locate_greatest t c = None) as Heq
              ; [ clear Hm ; eapply locate_greatest_fail_eq | rewrite Heq in Hm ]
          | [ H : not_empty_tree t |- _ ] =>
              assert (exists k v lM, locate_greatest t c = Some ((k,v),lM)) as Hex
              ; [ clear Hm ; eapply locate_greatest_success_eq
                | destruct Hex as [k Hex] ; destruct Hex as [v Hex]
                  ; destruct Hex as [lM Heq] ; rewrite Heq in Hm ]
          | _ => destruct (empty_tree_dp t) ; locate_greatest_match_progress
          end
      end.

    Lemma locate_greatest_two_maps_intro_c' :
      forall {k k' v v' t c  c'},
      locate_greatest t c = Some ((k',v'),inl c')
      -> maps_tree k v t
      -> k /~= k'
      -> maps_context k v c'.
    Admitted.
    Hint Resolve locate_greatest_two_maps_intro_c'.

    (*
    (*
    Lemma locate_greatest_success_result_ineq :
      forall {k k' v t c cM},
      locate_greatest t c = Some (k',v,cM)
      -> not_in_tree k t
      -> k /~= k'.
    Admitted.
    Hint Resolve locate_greatest_success_result_ineq.

    Lemma locate_greatest_success_three_p_ineq :
      forall {k k' v' t c k'' v'' c'},
      locate_greatest t c = Some ((k',v'),inr((k'',v''),c'))
      -> not_in_tree k t
      -> k /~= k''.
    Admitted.
    Hint Resolve locate_greatest_success_three_p_ineq.
*)

    Lemma locate_greatest_two_maps_intro_k :
      forall {k k' v v' t c  c'},
      locate_greatest t c = Some ((k',v'),inl c')
      -> maps_tree k v t
      -> not_in_context k c'
      -> k /~= k'.
    Admitted.
    Hint Resolve locate_greatest_two_maps_intro_k.

    Lemma locate_greatest_two_maps_intro_v :
      forall {k k' v v' t c  c'},
      locate_greatest t c = Some ((k',v'),inl c')
      -> maps_tree k v t
      -> not_in_context k c'
      -> v = v'.
    Admitted.
    Hint Resolve locate_greatest_two_maps_intro_v.

    Lemma locate_greatest_success_two_not_in :
      forall {k k' v' t c c'},
      locate_greatest t c = Some ((k',v'), inl c')
      -> not_in_tree k t
      -> not_in_context k c
      -> not_in_context k c'.
    Admitted.
    Hint Resolve locate_greatest_success_two_not_in.

    Lemma locate_greatest_success_three_in :
      forall {k k' v' k'' v'' t c  c'},
      locate_greatest t c = Some ((k',v'),inr ((k'',v''),c'))
      -> in_tree k t
      -> k ~= k' \/ k ~= k'' \/ in_context k c'.
    Admitted.

    Lemma locate_greatest_success_three_not_in :
      forall {k k' v' k'' v'' t c c'},
      locate_greatest t c = Some ((k',v'), inr((k'',v''),c'))
      -> not_in_tree k t
      -> not_in_context k c
      -> not_in_context k c'.
    Admitted.
    Hint Resolve locate_greatest_success_three_not_in.

    Lemma locate_greatest_success_two_bst :
      forall {k v l_t u_t t l_r u_r c c'},
      locate_greatest t c = Some ((k,v), inl c')
      -> bst_tree l_t u_t t
      -> bst_context l_r u_r l_t u_t c
      -> exists l_p u_p, bst_context l_r (Extend k) l_p u_p c' /\ Extend k <= u_t.
    Admitted.
    *)

    Lemma locate_greatest_success_two_balance :
      forall {n t n' c k v c'},
      locate_greatest t c = Some ((k,v),inl c')
      -> balance_tree n t
      -> balance_context n n' c
      -> balance_context (0+1) n' c'.
    Admitted.
    Hint Resolve locate_greatest_success_two_balance.

    (* Lemmas about insert_up *)

    Lemma insert_up_maps_k :
      forall {k v tl tr c},
      not_in_context k c
      -> maps_tree k v (insert_up (tl,(k,v),tr) c).
    Admitted.
    Hint Resolve insert_up_maps_k.

    Lemma insert_up_maps_intro :
      forall {k k' v v' tl tr c},
      k /~= k'
      -> maps_context k v c
      -> maps_tree k v (insert_up (tl,(k',v'),tr) c).
    Admitted.
    Hint Resolve insert_up_maps_intro.

    Lemma insert_up_maps_elim_c :
      forall {k k' v v' tl tr c},
      k /~= k'
      -> maps_tree k v (insert_up (tl,(k',v'),tr) c)
      -> not_in_tree k tl
      -> not_in_tree k tr
      -> maps_context k v c.
    Admitted.
    Hint Resolve insert_up_maps_elim_c.

    Lemma insert_up_bst :
      forall {k v tl tr l_r u_r l_t u_t c},
      bst_context l_r u_r l_t u_t c
      -> bst_tree l_t (Extend k) tl
      -> bst_tree (Extend k) u_t tr
      -> bst_tree l_r u_r (insert_up (tl,(k,v),tr) c).
    Admitted.
    Hint Resolve insert_up_bst.

    Lemma insert_up_balance :
      forall n tl k v tr n' c,
      balance_tree n tl
      -> balance_tree n tr
      -> balance_context n n' c
      -> exists n'', balance_tree n'' (insert_up (tl,(k,v),tr) c).
    Admitted.
    Hint Resolve insert_up_balance.

    (* Lemmas about insert_with. *)

    Lemma insert_with_maps_k :
      forall {f k v v' t},
      maps_tree k v' t
      -> maps_tree k (f v v') (insert_with f k v t).
    Proof. intros ; unfold insert_with ; locate_match_progress ; eauto. Qed.

    Lemma insert_with_not_in_k :
      forall {f k v t}, not_in_tree k t -> maps_tree k v (insert_with f k v t).
    Proof. intros ; unfold insert_with ; locate_match_progress ; eauto. Qed.

    Lemma insert_with_maps_intro :
      forall {f k k' v v' t},
      k /~= k'
      -> maps_tree k v t
      -> maps_tree k v (insert_with f k' v' t).
    Proof. intros ; unfold insert_with ; in_tree_case k' t ; locate_match_progress ; eauto. Qed.

    Lemma insert_with_maps_elim :
      forall {f k k' v v' t},
      k /~= k'
      -> maps_tree k v (insert_with f k' v' t)
      -> maps_tree k v t.
    Proof. intros ; unfold insert_with in * ; in_tree_case k' t ; locate_match_progress ; eauto. Qed.

    Lemma insert_with_bst :
      forall {f k v l_t u_t t},
      l_t <= Extend k <= u_t
      -> bst_tree l_t u_t t
      -> bst_tree l_t u_t (insert_with f k v t).
    Proof.
      intros ; unfold insert_with in * ; in_tree_case k' t
      ; locate_match_progress ; try pose_locate_fail_bst_top_ex ; eauto.
    Qed.

    Lemma insert_with_balance :
      forall f k v n t,
      balance_tree n t -> exists n', balance_tree n' (insert_with f k v t).
    Proof. intros ; unfold insert_with in * ; in_tree_case k t ; locate_match_progress ; eauto. Qed.

    (* Lemmas about remove_up *)

    Lemma remove_up_wf :
      forall {n t n' c},
      balance_tree n t -> balance_context (n+1) n' c -> exists t', remove_up t c = Some t'.
    Admitted.
    (*
    Proof.
      intros n t n' c ; gd n' ; gd t ; gd n ; induction c ; intros ; simpl
      ; repeat mysimp || atom_match_drill || auto ; eauto.
    Qed.
    *)

    Ltac remove_up_wf_progress_goal :=
      let Heq := fresh "Heq" in
      let t' := fresh "t'" in
      match goal with
      | [ |- context [ remove_up ?t ?c ] ] =>
          assert (exists t', remove_up t c = Some t') as Hex
          ; [ eapply remove_up_wf
            | destruct Hex as [t' Heq] ; rewrite Heq
            ]
      end.

    Lemma remove_up_maps_intro :
      forall {k v t c t'},
      remove_up t c = Some t'
      -> maps_tree k v t \/ maps_context k v c
      -> maps_tree k v t'.
    Admitted.
    Hint Resolve remove_up_maps_intro.

    (*
    Lemma remove_up_not_in :
      forall {k t c t'},
      remove_up t c = Some t'
      -> not_in_tree k t
      -> not_in_context k c
      -> not_in_tree k t'.
    Admitted.
    Hint Resolve remove_up_not_in.

    *)

    (* Lemmas about remove *)

    Lemma remove_wf :
      forall {k n t},
      balance_tree n t -> exists t' vM, remove k t = Some (t',vM).
    Admitted.
    (*
    Proof.
      intros ; unfold remove
      ; repeat
          mysimp || locate_match_progress || locate_greatest_match_progress
          || let_pair_drill || atom_match_drill
          || pose_locate_success_balance
          || remove_up_wf_progress_goal
      ; eauto ; try (compute ; eauto ; fail).
    Qed.
    *)

    Lemma remove_wf_maps_k :
      forall k v n t,
      balance_tree n t -> maps_tree k v t -> exists t', remove k t = Some (t',Some v).
    Admitted.
    (*
    Proof.
      intros ; unfold remove
      ; repeat
          mysimp
          || locate_match_progress || locate_greatest_match_progress
          || let_pair_drill || atom_match_drill
          || pose_locate_success_balance
          || remove_up_wf_progress_goal
      ; eauto ; try (compute ; eauto ; fail).
    Qed.
    *)

    Lemma remove_wf_not_in_k :
      forall k n t,
      balance_tree n t -> not_in_tree k t -> exists t', remove k t = Some (t',None).
    Admitted.
    (*
    Proof. intros ; unfold remove ; repeat mysimp || locate_match_progress ; eauto. Qed.
    *)

    Ltac fmap_success_eq :=
      match goal with
      | [ H : fmap ?f ?xM = Some ?x |- _ ] =>
          let X := fresh "X" in
          remember xM as X ; flip_eqn xM ; destruct X ; unfold fmap in * ; simpl in *
          ; try congruence
      end.
    Ltac mysimp2 := mysimp1 || fmap_success_eq.
    Ltac mysimp ::= mysimp2.

    Lemma locate_greatest_maps_two_elim_k :
      forall {t k v c},
      locate_greatest t c = Some (k,v,inl c)
      -> not_in_context k c
      -> maps_tree k v t.
    Admitted.
    Hint Resolve locate_greatest_maps_two_elim_k.

    Lemma remove_maps_intro :
      forall k v k' n t t' vM,
      remove k' t = Some (t',vM)
      -> k /~= k'
      -> balance_tree n t
      -> maps_tree k v t
      -> maps_tree k v t'.
    Proof.
      intros ; unfold remove in *
      ; repeat
          mysimp
          || locate_match_progress
          || locate_greatest_match_progress
          || let_pair_drill || atom_match_drill
          || pose_locate_success_balance
      ; eauto.
      - eapply remove_up_maps_intro ; eauto ; right.
        assert (maps_location k v (TwoHole_l t0 t1 c)) as Hml ; [eauto|]
        ; inversion Hml ; subst ; clear Hml ; eauto.
        remember (k ~=! k'1) as m ; destruct m ; repeat mysimp ; eauto.
        admit.
      -
        admit.
        admit.
        eauto.
        eauto.
        Show.
        admit.
        eapply fuse_maps_intro ; left.
        left.
        eapply locate_greatest_two_maps_intro_c' ; eauto.

        ; in_tree_case k t1 ; eauto.
      pose_locate_success_maps_intro ; eauto.
        repeat
          mysimp
          || locate_match_progress
          || locate_greatest_match_progress
          || let_pair_drill || atom_match_drill
          || pose_locate_success_balance
          || pose_locate_success_maps_intro.
      mysimp.
      pose_locate_success_maps_intro.
      let Hmaps := fresh "Hmaps" in
      let finish Heq c' k v l :=
        match goal with
        | [ H : maps_context k v c' |- _ ] => fail 1
        | _ => assert (maps_location k v l) as Hmaps
               ; [ eapply (locate_success_maps_intro Heq) ; clear Heq
                 | inversion Hmaps ; subst ; clear Hmaps ]
        end
      in
      match goal with
      | [ H : maps_tree ?k ?v ?t , Hneq : ?k /~= ?k' , Heq : locate ?k' ?t _ = inr (_,?l |- _ ] =>
          match l with
          | TwoHole_l _ _ ?c' => idtac
          | ThreeLeftHole_l _ _ _ _ ?c' => idtac
          | ThreeRightHole_l _ _ _ _ ?c' => idtac
          end
      end.

      - eapply remove_up_in ; eauto.
        right ; eauto.
        assert (in_location k (TwoHole_l t0 t1 c)) as H'
        ; [|inversion H' ; subst ; clear H'] ; eauto.
        assert (k ~= k'1 \/ in_context k c0) as H'
        ; [eapply locate_greatest_success_two_in|destruct H'] ; eauto.
      - assert (in_location k (TwoHole_l t0 t1 c)) as H'
        ; [|inversion H' ; subst ; clear H'] ; eauto.
        + assert (k ~= k'1 \/ k ~= k0 \/ in_context k c0) as H'
          ; [eapply locate_greatest_success_three_in|destruct H' as [Dis1|H'] ; [|destruct H']]
          ; eauto.
          eapply zip_in.
        + assert (k ~= k'1 \/ k ~= k0 \/ in_context k c0) as H'
          ; [eapply locate_greatest_success_three_in|] ; eauto.
          destruct H' as [f|H'].
        eapply fuse_in_c'.
        econstructor.
        eapply locate_greatest_success_result_ineq.
        eauto.
      ; eauto 30.

    Lemma remove_not_in :
      forall k n t t' vM,
      remove k t = Some (t',vM) -> balance_tree n t -> not_in_tree k t'.
    Admitted.
    (*
    Proof.
      intros ; unfold remove in *
      ; repeat
          mysimp
          || match goal with p : prod K V |- _ => destruct p end
          || locate_match_progress
          || locate_greatest_match_progress
          || let_pair_drill || atom_match_drill
          || fmap_success_eq
      ; eauto 30.
    Qed.
    *)

End TwoThreeTreesWF.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    Zp.v

    Build the group of the inversible element on {1, 2, .., n-1}
    for the multiplication modulo n

    Definition: ZpGroup
 **********************************************************************)
Require Import ZArith Znumtheory Zpow_facts.
Require Import Tactic.
Require Import Wf_nat.
Require Import UList.
Require Import FGroup.
Require Import EGroup.
Require Import IGroup.
Require Import Cyclic.
Require Import Euler.
Require Import ZProgression.

Open Scope Z_scope.

Section Zp.

Variable n: Z.

Hypothesis n_pos: 1 < n.

(**************************************
  mkZp m creates {m, m - 1, ..., 0}
 **************************************)

Fixpoint mkZp_aux (m: nat): list Z:=
  Z_of_nat m :: match m with O => nil | (S m1) => mkZp_aux m1 end.

(**************************************
  Some properties of mkZp_aux
 **************************************)

Theorem mkZp_aux_length: forall m, length (mkZp_aux m) = (m + 1)%nat.
intros m; elim m; simpl; auto.
Qed.

Theorem mkZp_aux_in: forall m p, 0 <= p <= Z_of_nat m -> In p (mkZp_aux m).
intros m; elim m.
simpl; auto with zarith.
intros n1 Rec p (H1, H2); case Zle_lt_or_eq with (1 := H2); clear H2; intro H2.
rewrite inj_S in H2.
simpl; right; apply Rec; split; auto with zarith.
rewrite H2; simpl; auto.
Qed.

Theorem in_mkZp_aux: forall m p, In p (mkZp_aux  m) ->  0 <= p <= Z_of_nat m.
intros m; elim m; clear m.
simpl; intros p H1; case H1; clear H1; intros H1; subst; auto with zarith.
intros m1; generalize (inj_S m1); simpl.
intros H Rec p [H1 | H1].
rewrite <- H1; rewrite H; auto with zarith.
rewrite H; case (Rec p); auto with zarith.
Qed.

Theorem mkZp_aux_ulist: forall m, ulist (mkZp_aux m).
intros m; elim m; simpl; auto.
intros m1 H; apply ulist_cons; auto.
change (~ In (Z_of_nat (S m1)) (mkZp_aux m1)).
rewrite inj_S; intros H1.
case in_mkZp_aux with (1 := H1); auto with zarith.
Qed.

(**************************************
  mkZp creates {n - 1, ..., 1, 0}
 **************************************)

Definition mkZp := mkZp_aux (Zabs_nat (n - 1)).

(**************************************
  Some properties of mkZp
 **************************************)

Theorem mkZp_length: length mkZp = Zabs_nat n.
unfold mkZp; rewrite mkZp_aux_length.
apply inj_eq_rev.
rewrite inj_plus.
simpl; repeat rewrite inj_Zabs_nat; auto with zarith.
repeat rewrite Zabs_eq; auto with zarith.
Qed.

Theorem mkZp_in: forall p, 0 <= p < n -> In p mkZp.
intros p (H1, H2); unfold mkZp; apply mkZp_aux_in.
rewrite inj_Zabs_nat; auto with zarith.
repeat rewrite Zabs_eq; auto with zarith.
Qed.

Theorem in_mkZp: forall p, In p mkZp ->  0 <= p < n.
intros p H; case (in_mkZp_aux (Zabs_nat  (n - 1)) p); auto with zarith.
rewrite inj_Zabs_nat; auto with zarith.
repeat rewrite Zabs_eq; auto with zarith.
Qed.

Theorem mkZp_ulist: ulist mkZp.
unfold mkZp; apply mkZp_aux_ulist; auto.
Qed.

(**************************************
  Multiplication of two pairs
 **************************************)

Definition pmult (p q: Z) := (p * q) mod n.

(**************************************
  Properties of multiplication
 **************************************)

Theorem pmult_assoc: forall p q r, (pmult p (pmult q r)) = (pmult (pmult p q) r).
assert (Hu: 0 < n); try apply Zlt_trans with 1; auto with zarith.
generalize Zmod_mod; intros H.
intros p q r; unfold pmult.
rewrite (Zmult_mod p); auto.
repeat rewrite Zmod_mod; auto.
rewrite (Zmult_mod q); auto.
rewrite <- Zmult_mod; auto.
rewrite Zmult_assoc.
rewrite (Zmult_mod (p * (q mod n))); auto.
rewrite (Zmult_mod ((p * q) mod n)); auto.
eq_tac; auto.
eq_tac; auto.
rewrite (Zmult_mod p); sauto.
rewrite Zmod_mod; auto.
rewrite <- Zmult_mod; sauto.
Qed.

Theorem pmult_1_l: forall p, In p mkZp -> pmult 1 p = p.
intros p H; unfold pmult; rewrite Zmult_1_l.
apply Zmod_small.
case (in_mkZp p); auto with zarith.
Qed.

Theorem pmult_1_r: forall p, In p mkZp -> pmult p 1 = p.
intros p H; unfold pmult; rewrite Zmult_1_r.
apply Zmod_small.
case (in_mkZp p); auto with zarith.
Qed.

Theorem pmult_comm: forall p q, pmult p q = pmult q p.
intros p q; unfold pmult; rewrite Zmult_comm; auto.
Qed.

Definition Lrel := isupport_aux _ pmult  mkZp 1 Z_eq_dec (progression Zsucc 0 (Zabs_nat n)).

Theorem rel_prime_is_inv:
  forall a, is_inv Z pmult mkZp 1 Z_eq_dec a = if (rel_prime_dec a n) then true else false.
assert (Hu: 0 < n); try apply Zlt_trans with 1; auto with zarith.
intros a; case (rel_prime_dec a n); intros H.
assert (H1: Bezout a n 1); try apply rel_prime_bezout; auto.
inversion H1 as [c d Hcd]; clear H1.
assert (pmult (c mod n) a = 1).
unfold pmult; rewrite Zmult_mod; try rewrite Zmod_mod; auto.
rewrite <- Zmult_mod; auto.
replace (c * a) with (1 + (-d) * n).
rewrite Z_mod_plus; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite <- Hcd; ring.
apply is_inv_true with (a := (c mod n)); auto.
apply mkZp_in; auto with zarith.
exact pmult_1_l.
exact pmult_1_r.
rewrite pmult_comm; auto.
apply mkZp_in; auto with zarith.
apply Z_mod_lt; auto with zarith.
apply is_inv_false.
intros c H1; left; intros H2; contradict H.
apply bezout_rel_prime.
apply Bezout_intro with c  (- (Zdiv (c * a) n)).
pattern (c * a) at 1; rewrite (Z_div_mod_eq (c * a) n); auto with zarith.
unfold pmult in H2; rewrite (Zmult_comm c); try rewrite H2.
ring.
Qed.

(**************************************
   We are now ready to build our group
 **************************************)

Definition ZPGroup : (FGroup pmult).
apply IGroup with (support := mkZp) (e:= 1).
exact Z_eq_dec.
apply mkZp_ulist.
apply mkZp_in; auto with zarith.
intros a b H1 H2; apply mkZp_in.
unfold pmult; apply Z_mod_lt; auto with zarith.
intros; apply pmult_assoc.
exact pmult_1_l.
exact pmult_1_r.
Defined.

Theorem in_ZPGroup: forall p, rel_prime p n -> 0 <= p < n -> In p ZPGroup.(s).
intros p H (H1, H2); unfold ZPGroup; simpl.
apply isupport_is_in.
generalize (rel_prime_is_inv p); case (rel_prime_dec p); auto.
apply mkZp_in; auto with zarith.
Qed.

Theorem phi_is_length: phi n = Z_of_nat (length Lrel).
assert (Hu: 0 < n); try apply Zlt_trans with 1; auto with zarith.
rewrite phi_def_with_0; auto.
unfold Zsum, Lrel; rewrite Zle_imp_le_bool; auto with zarith.
replace (1 + (n - 1) - 0) with n; auto with zarith.
elim (progression Zsucc 0 (Zabs_nat n)); simpl; auto.
intros a l1 Rec.
rewrite Rec.
rewrite rel_prime_is_inv.
case (rel_prime_dec a n); auto with zarith.
simpl length; rewrite inj_S; auto with zarith.
Qed.

Theorem phi_is_order: phi n = g_order ZPGroup.
unfold g_order; rewrite phi_is_length.
eq_tac; apply permutation_length.
apply ulist_incl2_permutation.
unfold Lrel; apply isupport_aux_ulist.
apply ulist_Zprogression; auto.
apply ZPGroup.(unique_s).
intros a H; unfold ZPGroup; simpl.
apply isupport_is_in.
unfold Lrel in H; apply  isupport_aux_is_inv_true with (1 := H).
apply mkZp_in; auto.
assert (In a (progression Zsucc 0 (Zabs_nat  n))).
apply  (isupport_aux_incl _ pmult mkZp 1 Z_eq_dec); auto.
split.
apply Zprogression_le_init with (1 := H0).
replace n with (0 + Z_of_nat (Zabs_nat n)).
apply Zprogression_le_end with (1 := H0).
rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
intros a H; unfold Lrel; simpl.
apply isupport_aux_is_in.
simpl in H; apply  isupport_is_inv_true with (1 := H).
apply in_Zprogression.
rewrite Zplus_0_l; rewrite inj_Zabs_nat; auto with zarith.
rewrite Zabs_eq; auto with zarith.
assert (In a mkZp).
apply  (isupport_aux_incl _ pmult mkZp 1 Z_eq_dec); auto.
apply in_mkZp; auto.
Qed.

Theorem Zp_cyclic: prime n -> cyclic Z_eq_dec ZPGroup.
intros H1.
unfold ZPGroup, pmult;
generalize (cyclic_field _ (fun x y => (x + y) mod n) (fun x y => (x *  y) mod n) (fun x => (-x) mod n) 0);
unfold IA; intros tmp; apply tmp; clear tmp; auto.
intros; discriminate.
apply mkZp_in; auto with zarith.
intros; apply mkZp_in; auto with zarith.
apply Z_mod_lt; auto with zarith.
intros; rewrite Zplus_0_l; auto.
apply Zmod_small; auto.
apply in_mkZp; auto.
intros; rewrite Zplus_comm; auto.
intros a b c Ha Hb Hc.
pattern a at 1; rewrite <- (Zmod_small a n); auto with zarith.
pattern c at 2; rewrite <- (Zmod_small c n); auto with zarith.
repeat rewrite <- Zplus_mod; auto with zarith.
eq_tac; auto with zarith.
apply in_mkZp; auto.
apply in_mkZp; auto.
intros; eq_tac; auto with zarith.
intros a b c Ha Hb Hc.
pattern a at 1; rewrite <- (Zmod_small a n); auto with zarith.
repeat rewrite <- Zmult_mod; auto with zarith.
repeat rewrite <- Zplus_mod; auto with zarith.
eq_tac; auto with zarith.
apply in_mkZp; auto.
intros; apply mkZp_in; apply Z_mod_lt; auto with zarith.
intros a Ha.
pattern a at 1; rewrite <- (Zmod_small a n); auto with zarith.
repeat rewrite <- Zplus_mod; auto with zarith.
rewrite <- (Zmod_small 0 n); auto with zarith.
eq_tac; auto with zarith.
apply in_mkZp; auto.
intros a b Ha Hb H; case (prime_mult n H1 a b).
apply Zmod_divide; auto with zarith.
intros H2; left.
case (Zle_lt_or_eq 0 a); auto.
case (in_mkZp a); auto.
intros H3; absurd (n <= a).
apply Zlt_not_le.
case (in_mkZp a); auto.
apply Zdivide_le; auto with zarith.
intros H2; right.
case (Zle_lt_or_eq 0 b); auto.
case (in_mkZp b); auto.
intros H3; absurd (n <= b).
apply Zlt_not_le.
case (in_mkZp b); auto.
apply Zdivide_le; auto with zarith.
Qed.

End Zp.

(* Definition of the order (0 for q < 1) *)

Definition Zorder: Z -> Z -> Z.
intros p q; case (Z_le_dec q 1); intros H.
exact 0.
refine (e_order Z_eq_dec (p mod q) (ZPGroup q _)); auto with zarith.
Defined.

Theorem Zorder_pos: forall p n, 0 <= Zorder p n.
intros p n; unfold Zorder.
case (Z_le_dec n 1); auto with zarith.
intros n1.
apply Zlt_le_weak; apply e_order_pos.
Qed.

Theorem in_mod_ZPGroup
     : forall (n : Z) (n_pos : 1 < n) (p : Z),
       rel_prime p n -> In (p mod n) (s (ZPGroup n n_pos)).
intros n H p H1.
apply in_ZPGroup; auto.
apply rel_prime_mod; auto with zarith.
apply Z_mod_lt; auto with zarith.
Qed.

Theorem Zpower_mod_is_gpow:
  forall p q n (Hn: 1 < n), rel_prime p n -> 0 <= q -> p ^ q mod n = gpow (p mod n) (ZPGroup n Hn) q.
intros p q n H Hp H1; generalize H1; pattern q; apply natlike_ind; simpl; auto.
intros _; apply Zmod_small; auto with zarith.
intros n1 Hn1 Rec _; simpl.
generalize (in_mod_ZPGroup _ H _ Hp); intros Hu.
unfold Zsucc; rewrite Zpower_exp; try rewrite Zpower_1_r; auto with zarith.
rewrite gpow_add; auto with zarith.
rewrite gpow_1; auto; rewrite <- Rec; auto.
rewrite Zmult_mod; auto.
Qed.

Theorem Zorder_div_power: forall p q n, 1 < n -> rel_prime p n -> p ^ q  mod n = 1 -> (Zorder p n | q).
intros p q n H H1 H2.
assert (Hq: 0 <= q).
generalize H2; case q; simpl; auto with zarith.
intros p1 H3; contradict H3; rewrite Zmod_small; auto with zarith.
unfold Zorder; case (Z_le_dec n 1).
intros H3; contradict H; auto with zarith.
intros H3; apply e_order_divide_gpow; auto.
apply in_mod_ZPGroup; auto.
rewrite <- Zpower_mod_is_gpow; auto with zarith.
Qed.

Theorem Zorder_div:  forall p n,  prime n -> ~(n | p) -> (Zorder p n | n - 1).
intros p n H; unfold Zorder.
case (Z_le_dec n 1); intros H1 H2.
contradict H1; generalize (prime_ge_2 n H); auto with zarith.
rewrite <- prime_phi_n_minus_1; auto.
match goal with |- context[ZPGroup _ ?H2] => rewrite phi_is_order with (n_pos := H2) end.
apply e_order_divide_g_order; auto.
apply in_mod_ZPGroup; auto.
apply rel_prime_sym; apply prime_rel_prime; auto.
Qed.

Theorem Zorder_power_is_1:  forall p n, 1 < n -> rel_prime p n -> p ^ (Zorder p n)  mod n = 1.
intros p n H H1;  unfold Zorder.
case (Z_le_dec n 1); intros H2.
contradict H; auto with zarith.
let x := match goal with |- context[ZPGroup _ ?X] => X end  in  rewrite Zpower_mod_is_gpow with (Hn := x); auto with zarith.
rewrite gpow_e_order_is_e.
reflexivity.
apply in_mod_ZPGroup; auto.
apply Zlt_le_weak; apply e_order_pos.
Qed.

Theorem Zorder_power_pos: forall p n, 1 < n -> rel_prime p n -> 0 < Zorder p n.
intros p n H H1;  unfold Zorder.
case (Z_le_dec n 1); intros H2.
contradict H; auto with zarith.
apply e_order_pos.
Qed.

Theorem phi_power_is_1:  forall p n, 1 < n -> rel_prime p n -> p ^ (phi n)  mod n = 1.
intros p n H H1.
assert (V1:= Zorder_power_pos p n H H1).
assert (H2: (Zorder p n | phi n)).
unfold Zorder.
case (Z_le_dec n 1); intros H2.
contradict H; auto with zarith.
match goal with |- context[ZPGroup n ?H] =>
rewrite phi_is_order  with (n_pos := H)
end.
apply e_order_divide_g_order.
apply in_mod_ZPGroup; auto.
case H2; clear H2; intros q H2; rewrite H2.
rewrite Zmult_comm.
assert (V2 := (phi_pos _ H)).
assert (V3: 0 <= q).
rewrite H2 in V2.
apply Zlt_le_weak; apply Zmult_lt_0_reg_r with (2 := V2); auto with zarith.
rewrite Zpower_mult; auto with zarith.
rewrite Zpower_mod; auto with zarith.
rewrite Zorder_power_is_1; auto.
rewrite Zpower_1_l; auto with zarith.
apply Zmod_small; auto with zarith.
Qed.


Theorem mult_1_plus : forall n m : nat,
  (1 + n) * m = m + (n * m).
Proof.
 intros n m. rewrite plus_1_l. simpl. reflexivity. Qed.


Require Import List Coq.Relations.Relation_Operators Coq.Relations.Operators_Properties Omega Case Useful.

Set Implicit Arguments.

Inductive Tree : Set :=
  | C : list nat -> list Tree -> Tree.

Definition parent c p :=
  match p with
    | C n ls => In c ls
  end.

Definition leaf c := match c with
                       | C _ ls => match ls with
                                     | nil => True
                                     | _ => False
                                   end
                     end.

Definition descendent := clos_refl_trans Tree parent.
Definition descn1 := clos_refl_trans_n1 Tree parent.
Definition desc1n := clos_refl_trans_1n Tree parent.

Section Tree_ind1.
  Variable P : Tree -> Prop.

  Hypothesis Ccase :
    forall n ls, (forall c, parent c (C n ls) -> P c) -> P (C n ls).

  Theorem indCase t (Pt: P t) rest (Prest: forall c, In c rest -> P c):
    forall c, In c (t::rest) -> P c.
  Proof.
    intros c opts.
    destruct opts as [t_eq_c | forRest].
    rewrite <- t_eq_c; assumption.
    apply (Prest c forRest).
  Qed.

  Fixpoint Tree_ind1 (tr : Tree) : P tr :=
    match tr with
      | C n ls => Ccase n ls
                        ((fix list_Tree_ind ls :=
                            match ls as lsl return forall c, In c lsl -> P c with
                              | nil => fun c inNil => False_ind (P c) inNil
                              | tr' :: rest => indCase (Tree_ind1 tr') (list_Tree_ind rest)
                            end) ls)
    end.
End Tree_ind1.

Fixpoint decTree (t1 t2: Tree): {t1 = t2} + {t1 <> t2}.
Proof.
  repeat decide equality.
Qed.

Fixpoint ht t := match t with
                   | C _ ls => (fix f ls :=
                                  match ls with
                                    | nil => 0
                                    | x :: xs => S (max (ht x) (f xs))
                                  end) ls
                 end.

Theorem maxProp: forall x y, S (max x y) > x.
Proof.
  intros x.
  induction x.
  intros y; omega.
  intros y.
  unfold max.
  fold max.
  destruct y.
  omega.
  specialize (IHx y).
  omega.
Qed.

Theorem maxProp2: forall x y, max x y >= y.
Proof.
  intros x.
  induction x.
  intros y; unfold max.
  omega.
  intros y.
  unfold max.
  fold max.
  destruct y.
  omega.
  specialize (IHx y).
  omega.
Qed.

Theorem parentHt: forall p c, parent c p -> ht p > ht c.
Proof.
  intros p c c_p.
  unfold parent in *.
  destruct p.
  induction l0.
  unfold In in *.
  firstorder.
  unfold In in c_p.
  destruct c_p as [eq| neq].
  rewrite eq.
  unfold ht.
  fold ht.
  apply (maxProp (ht c) ((fix f (ls : list Tree) : nat :=
            match ls with
            | nil => 0
            | x :: xs => S (max (ht x) (f xs))
            end) l0)).
  unfold ht.
  fold ht.
  specialize (IHl0 neq); clear neq.
  pose proof (maxProp2 (ht a) ((fix f (ls : list Tree) : nat :=
            match ls with
            | nil => 0
            | x :: xs => S (max (ht x) (f xs))
            end) l0)) as use.
  assert (use2: S (max (ht a)
          ((fix f (ls : list Tree) : nat :=
              match ls with
              | nil => 0
              | x :: xs => S (max (ht x) (f xs))
              end) l0)) >= S ((fix f (ls : list Tree) : nat :=
           match ls with
           | nil => 0
           | x :: xs => S (max (ht x) (f xs))
           end) l0)) by omega.
  unfold ht in IHl0; fold ht in IHl0.
  omega.
Qed.

Theorem descHt p c: descendent c p -> ht p >= ht c.
Proof.
  intros desc.
  induction desc.
  pose proof (parentHt _ _ H).
  omega.
  omega.
  omega.
Qed.

Theorem noCycle: forall p c, parent c p -> parent p c -> False.
Proof.
  intros p c c_p p_c.
  pose proof (parentHt _ _ c_p) as a1.
  pose proof (parentHt _ _ p_c) as a2.
  omega.
Qed.

Theorem noParentChild: forall p c, c = p -> parent c p -> False.
Proof.
  intros p c p_eq_c c_p.
  rewrite p_eq_c in *.
  pose proof (parentHt _ _ c_p).
  omega.
Qed.

Theorem descNoChildFalse: forall c x, c <> (C x nil) -> descendent c (C x nil) -> False.
Proof.
  intros c x c_ne d.
  remember (C x nil) as u.
  induction d.
  rewrite Hequ in H.
  unfold parent in H.
  intuition.
  intuition.
  rewrite Hequ in *.
  assert (H: C x nil = C x nil) by reflexivity.
  specialize (IHd2 H).
  destruct (decTree y (C x nil)).
  destruct (decTree x0 y).
  rewrite e0 in *.
  intuition.
  rewrite e in *.
  intuition.
  intuition.
Qed.

Theorem isOrNotDesc:
  forall p c,
    descendent c p \/ ~ descendent c p.
Proof.
  intros p c.
  induction p using Tree_ind1.

  destruct (decTree c (C n ls)).

  Case "p = c".
  rewrite e.
  left.
  constructor 2.

  Case "p <> c".
  assert (sth: (exists c0, parent c0 (C n ls) /\ descendent c c0) \/
               forall c0, parent c0 (C n ls) -> descendent c c0 -> False).
  clear n0.
  unfold parent in *.
  clear n.
  apply (exOrNotforall _ _ H).
  destruct sth.
  destruct H0 as [c0 [c0_p c_c0]].
  assert (descendent c0 (C n ls)) by (constructor 1; assumption).
  left.
  constructor 3 with c0; assumption.
  right.
  unfold not; intros d.
  pose proof (clos_rt_rtn1 _ _ _ _ d) as sth.
  destruct sth.
  intuition.
  pose proof (clos_rtn1_rt _ _ _ _ sth) as d'.
  apply (H0 y H1 d').
Qed.

Theorem commonDec:
  forall top c1 c2,
    descendent c1 top -> descendent c2 top ->
    ((exists c, parent c top /\
               descendent c1 c /\
               descendent c2 c) \/
     forall c, parent c top -> descendent c1 c -> descendent c2 c -> False).
Proof.
  intros top c1 c2 d1 d2.
  pose proof (clos_rt_rtn1 _ _ _ _ d1) as d1'.
  pose proof (clos_rt_rtn1 _ _ _ _ d2) as d2'.
  clear d1 d2.
  induction d1'.
  right.
  intros c c_c1 c1_c c2_c.
  pose proof (descHt c1_c) as one.
  pose proof (parentHt _ _ c_c1) as two.
  assert False by omega; intuition.
  destruct d2'.
  right.
  intros c c_c2 c1_c c2_c.
  pose proof (descHt c2_c) as one.
  pose proof (parentHt _ _ c_c2) as two.
  assert False by omega; intuition.
  pose proof (clos_rtn1_rt _ _ _ _ d1') as d1.
  pose proof (clos_rtn1_rt _ _ _ _ d2') as d2.
  assert (comm: forall x c, parent c z -> descendent x c \/ ~ descendent x c).
  intros x c c_z.
  apply (isOrNotDesc c x).
  pose proof (comm c1) as com1.
  pose proof (comm c2) as com2; clear comm.
  assert (comm: forall c, parent c z ->
                          (descendent c1 c /\ descendent c2 c) \/
                          ~ (descendent c1 c /\ descendent c2 c)).
  intros c c_z.
  specialize (com1 c c_z).
  specialize (com2 c c_z).
  intuition.
  destruct z.
  pose proof (exOrNotforall _ _ comm) as opts.
  generalize opts; clear; firstorder.
Qed.

Theorem hasFork':
  forall c1 c2,
    ~ descendent c1 c2 -> ~ descendent c2 c1 ->
    forall top,
      descendent c1 top -> descendent c2 top ->
      exists fork, descendent fork top /\
                   (exists d1, descendent d1 top /\ parent d1 fork /\
                               descendent c1 d1 /\ ~ descendent c2 d1) /\
                   (exists d2, descendent d2 top /\
                               parent d2 fork /\ ~ descendent c1 d2 /\ descendent c2 d2).
Proof.
  intros c1 c2 c1_no_c2 c2_no_c1.
  induction top using Tree_ind1.
  intros c1_C_n_ls c2_C_n_ls.
  pose proof (commonDec c1_C_n_ls c2_C_n_ls) as [[c [c_child [c1_c c2_c]]]|noEx].
  specialize (H c c_child c1_c c2_c).
  destruct H as [fork [fork_c use]].
  destruct use as [[d1 [d1_c r1]] [d2 [d2_c r2]]].
  pose proof (rt_step Tree parent c (C n ls) c_child) as c_C_n_ls.
  pose proof (rt_trans Tree parent fork c (C n ls) fork_c c_C_n_ls) as fork_C_n_ls.
  pose proof (rt_trans Tree parent d1 c (C n ls) d1_c c_C_n_ls) as d1_C_n_ls.
  pose proof (rt_trans Tree parent d2 c (C n ls) d2_c c_C_n_ls) as d2_C_n_ls.
  firstorder.
  exists (C n ls).
  constructor. apply (rt_refl Tree parent (C n ls)).
  pose proof (clos_rt_rtn1 Tree parent c1 (C n ls) c1_C_n_ls) as transChange1.
  destruct transChange1 as [easy|d1].
  firstorder.
  pose proof (clos_rtn1_rt Tree parent c1 d1 transChange1) as c1_d1.
  fold descendent in c1_d1.
  pose proof (clos_rt_rtn1 Tree parent c2 z c2_C_n_ls) as transChange2.
  destruct transChange2 as [easy|d2].
  firstorder.
  pose proof (clos_rtn1_rt Tree parent c2 d2 transChange2) as c2_d2.
  fold descendent in c2_d2; clear transChange1 transChange2.
  assert (cond1: ~ descendent c2 d1) by firstorder.
  assert (cond2: ~ descendent c1 d2) by firstorder.
  pose proof (rt_step Tree parent d1 z H0) as p1.
  pose proof (rt_step Tree parent d2 z H1) as p2.
  constructor.
  exists d1; firstorder.
  exists d2; firstorder.
Qed.

Theorem noLeafsDesc c1 c2: leaf c1 -> leaf c2 -> c1 <> c2 -> ~ descendent c1 c2.
Proof.
  unfold not; intros leaf_c1 leaf_c2 c1_ne_c2 c1_c2.
  pose proof (clos_rt_rtn1 Tree parent c1 c2 c1_c2) as trans.
  destruct trans as [easy|hard].
  auto.
  unfold parent in H. unfold leaf in leaf_c2.
  destruct z.
  destruct l0.
  unfold In in H.
  assumption.
  assumption.
Qed.

Definition treeNthName nm ls := forall n,
                                  n < List.length ls -> match nth n ls (C nil nil) with
                                                          | C x _ => x = n :: nm
                                                        end.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : lst) (x : lst) : natural :=
  len (append x (append Nil x)).


Require Import Coq.ZArith.BinInt.
Require Import riscv.Encode.
Require Import riscv.util.ZBitOps.
Require Import riscv.util.prove_Zeq_bitwise.

Lemma invert_encode_UJ: forall {opcode rd jimm20},
  verify_UJ opcode rd jimm20 ->
  forall inst,
  encode_UJ opcode rd jimm20 = inst ->
  opcode = bitSlice inst 0 7 /\
  rd = bitSlice inst 7 12 /\
  jimm20 = signExtend 21 (Z.shiftl (bitSlice inst 31 32) 20  <|>
                          Z.shiftl (bitSlice inst 21 31) 1  <|>
                          Z.shiftl (bitSlice inst 20 21) 11 <|>
                          Z.shiftl (bitSlice inst 12 20) 12).
Proof. intros. unfold encode_UJ, verify_UJ in *. prove_Zeq_bitwise. Qed.


(* No axiom is being used in this module *)

(* This is the reverse of Peirce law which is not very interesting *)
Proposition peirce_reverse : forall P Q: Prop, P->(P->Q)->P.
Proof.
  intros P Q Hp; intro Hpq; exact Hp.
Qed.

Proposition P_non_P : forall P:Prop, P->~~P.
Proof.
  intros P Hp; intro H; apply H; exact Hp.
Qed.

Proposition or_not_and_not : forall P Q:Prop, P\/Q->~(~P/\~Q).
Proof.
  intros P Q H; intro H'; elim H'; intros Hnp Hnq. elim H.
  intro Hp; apply Hnp; exact Hp.
  intro Hq; apply Hnq; exact Hq.
Qed.

Proposition not_P_or_imp : forall P Q: Prop, (~P\/Q)->(P->Q).
Proof.
  intros P Q H Hp. elim H. intro Hnp.
  apply False_ind. apply Hnp; exact Hp.
  intro Hq; exact Hq.
Qed.

Proposition forall_not_exists : forall (A:Type) (P: A->Prop),
  (forall x:A, P x) -> ~(exists x:A, ~P x).
Proof.
  intros A P H H'. elim H'. intros a Ha. apply Ha. apply H.
Qed.


Module EQ.
  Record class (T:Type) := Class {
    cmp: T -> T -> Prop
  }.

  Structure type := Pack {
    obj: Type;
    class_of: class obj
  }.

  Definition op (e:type) : obj e -> obj e -> Prop :=
    let 'Pack _ (Class _ the_cmp) := e in the_cmp.

  Check op.
  Arguments op {e} x y : simpl never.
  Arguments Class {T} cmp.

  Module theory.
    Notation "x == y" := (op x y) (at level 70).
  End theory.
End EQ.

Import EQ.theory.
Check forall (e:EQ.type) (a b: EQ.obj e), a == b.
Fail Check 3 == 3.

Definition nat_eq (x y:nat) := Nat.compare x y = Eq.
Definition nat_EQcl : EQ.class nat := EQ.Class nat_eq.
Canonical Structure nat_EQty : EQ.type := EQ.Pack nat nat_EQcl.

Check 3 == 3.

Eval compute in 3 == 4.

Fail Check forall (e:EQ.type) (a b: EQ.obj e), (a, b) == (a, b).

Definition pair_eq (e1 e2:EQ.type) (x y: EQ.obj e1 * EQ.obj e2) :=
  fst x == fst y /\ snd x == snd y.

Definition pair_EQcl e1 e2 := EQ.Class (pair_eq e1 e2).
Canonical Structure pair_EQty (e1 e2:EQ.type) : EQ.type :=
  EQ.Pack (EQ.obj e1 * EQ.obj e2) (pair_EQcl e1 e2).

Check forall (e:EQ.type) (a b:EQ.obj e), (a, b) == (a, b).
Check forall n m:nat, (3, 4) == (n, m).

Module LE.
  Record class T := Class {
    cmp: T -> T -> Prop
  }.

  Structure type := Pack {
    obj: Type;
    class_of: class obj
  }.

  Definition op (e:type) : obj e -> obj e -> Prop :=
    let 'Pack _ (Class _ f) := e in f.
  Arguments op {_} x y : simpl never.
  Arguments Class {T} cmp.

  Module theory.
    Notation "x <= y" := (op x y) (at level 70).
  End theory.
End LE.

Import LE.theory.
Definition nat_le x y := Nat.compare x y <> Gt.
Definition nat_LEcl : LE.class nat := LE.Class nat_le.
Canonical Structure nat_LEty : LE.type := LE.Pack nat nat_LEcl.

Definition pair_le e1 e2 (x y: LE.obj e1 * LE.obj e2) :=
  fst x <= fst y /\ snd x <= snd y.

Definition pair_LEcl e1 e2 := LE.Class (pair_le e1 e2).

Canonical Structure pair_LEty (e1 e2:LE.type) : LE.type :=
  LE.Pack (LE.obj e1 * LE.obj e2) (pair_LEcl e1 e2).

Check (3, 4, 5) <= (3, 4, 5).

Module LEQ.
  Record mixin (e:EQ.type) (le: EQ.obj e -> EQ.obj e -> Prop) :=
    Mixin { compat: forall x y:EQ.obj e, le x y /\ le y x <-> x == y }.

  Record class T := Class {
    EQ_class: EQ.class T;
    LE_class: LE.class T;
    extra: mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class)
  }.

  Structure type := _Pack {
    obj: Type;
    class_of: class obj
  }.

  Arguments Mixin {e le} _.
  Arguments Class {T} _ _ _.

  Module theory.
    Definition to_EQ (e:type) : EQ.type :=
      EQ.Pack (obj e) (EQ_class _ (class_of e)).

    Canonical Structure to_EQ.

    Definition to_LE (e:type) : LE.type :=
      LE.Pack (obj e) (LE_class _ (class_of e)).

    Canonical Structure to_LE.

    Lemma lele_eq (e:type) (x y:obj e) :
      x <= y -> y <=x -> x == y.
    Proof. intros. apply (compat _ _ (extra _ (class_of e)) x y). now split. Qed.

    Arguments lele_eq {e} x y _ _.
  End theory.
End LEQ.

Import LEQ.theory.
Check lele_eq.

Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m.
Fail apply (lele_eq n m).
Abort.
Example test_algebraic2 (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) :
     n <= m -> m <= n -> n == m.
Fail apply (lele_eq n m).
Abort.

Lemma nat_LEQ_compat (n m : nat) : n <= m /\ m <= n <-> n == m.
Admitted.
Definition nat_LEQmx := LEQ.Mixin nat_LEQ_compat.
Lemma pair_LEQ_compat (l1 l2 : LEQ.type) (n m : LEQ.obj l1 * LEQ.obj l2) :
   n <= m /\ m <= n <-> n == m.
Admitted.
Definition pair_LEQmx l1 l2 := LEQ.Mixin (pair_LEQ_compat l1 l2).

Module Add_instance_attempt.
  Canonical Structure nat_LEQty : LEQ.type :=
    LEQ._Pack nat (LEQ.Class nat_EQcl nat_LEcl nat_LEQmx).

  Canonical Structure pair_LEQty (l1 l2 : LEQ.type) : LEQ.type :=
  LEQ._Pack (LEQ.obj l1 * LEQ.obj l2)
    (LEQ.Class
        (EQ.class_of (pair_EQty (to_EQ l1) (to_EQ l2)))
        (LE.class_of (pair_LEty (to_LE l1) (to_LE l2)))
        (pair_LEQmx l1 l2)).
  Print Canonical Projections.

  Example test_algebraic (n m : nat) : n <= m -> m <= n -> n == m.
  now apply (lele_eq n m). Qed.

  Example test_algebraic2 (n m : nat * nat) : n <= m -> m <= n -> n == m.
  now apply (lele_eq n m). Qed.
End Add_instance_attempt.

Require Import Strings.String.

Module infrastructure.
  Inductive phantom {T : Type} (t : T) : Type := Phantom.

  Definition unify {T1 T2} (t1 : T1) (t2 : T2) (s : option string) :=
    phantom t1 -> phantom t2.

  Definition id {T} {t : T} (x : phantom t) := x.

  Notation "[find v | t1 ~ t2 ] p" := (fun v (_ : unify t1 t2 None) => p)
    (at level 50, v ident, only parsing).
  Notation "[find v | t1 ~ t2 | s ] p" := (fun v (_ : unify t1 t2 (Some s)) => p)
    (at level 50, v ident, only parsing).
  Notation "'Error : t : s" := (unify _ t (Some s))
    (at level 50, format "''Error' : t : s").
Open Scope string_scope.
End infrastructure.

Import infrastructure.
Definition packager T e0 le0 (m0 : LEQ.mixin e0 le0) :=
  [find e | EQ.obj e ~ T | "is not an EQ.type" ]
  [find o | LE.obj o ~ T | "is not an LE.type" ]
  [find ce | EQ.class_of e ~ ce ]
  [find co | LE.class_of o ~ co ]
  [find m | m ~ m0 | "is not the right mixin" ]
  LEQ._Pack T (LEQ.Class ce co m).
Notation Pack T m := (packager T _ _ m _ id _ id _ id _ id _ id).

Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx.

Canonical Structure pair_LEQty (l1 l2 : LEQ.type) :=
   Eval hnf in Pack (LEQ.obj l1 * LEQ.obj l2) (pair_LEQmx l1 l2).