From Undecidability Require Import Synthetic.DecidabilityFacts Synthetic.SemiDecidabilityFacts Synthetic.EnumerabilityFacts Synthetic.ListEnumerabilityFacts reductions partial embed_nat ReducibilityFacts truthtables bestaxioms.
Require Import Setoid Program Lia List.

Axiom EA : EA.

Notation φ := (proj1_sig EA).
Notation EAP := (proj2_sig EA).

Lemma EAS : forall p : nat -> nat -> Prop, enumerable (uncurry p) -> exists γ, forall x, enumerator (φ (γ x)) (p x).
Proof.
  intros p [γ H] % penumerable_iff % EAP; firstorder; eauto.
  eapply discrete_nat.
Qed.

Definition W c x := exists n, φ c n = Some x.

Lemma W_spec : forall p, enumerable p <-> exists c, forall x, p x <-> W c x.
Proof.
  intros p.
  split.
  - intros [f Hf].
    destruct (EAP (fun _ => p)) as [γ H].
    + exists (fun _ => f). firstorder.
    + exists (γ 0). firstorder.
  - intros [c H]. exists (φ c). firstorder.
Qed.

Lemma do_EA p : enumerable p -> exists c, forall x, p x <-> W c x.
Proof.
  eapply W_spec.
Qed.

Hint Resolve discrete_nat : core.

Lemma EAS' :
  forall p : nat -> nat -> Prop, enumerable (fun! ⟨x,y⟩ => p x y) ->
                                        exists c : nat -> nat, forall x y, p x y <-> W (c x) y.
Proof.
  intros p Hp.
  eapply EAS, enumerable_red; eauto.
  exists embed. red. intros [x y]. now rewrite embedP.
Qed.

Lemma EAS_datatype X (p : X -> nat -> Prop) (x0 : X) :
  datatype X ->
  enumerable (uncurry p) ->
  exists c : X -> nat, forall x y, p x y <-> W (c x) y.
Proof.
  intros (I & R & HIR) Ep.
  destruct (EAS (fun x y => if R x is Some l then p l y else p x0 y)) as [c Hc].
  - eapply enumerable_red.
    4: eapply Ep.
    + exists (fun '(x, y) => if R x is Some l then (l,y) else (x0, y)).
      intros [x y]. cbn.
      destruct (R x); reflexivity.
    + eauto.
    + eapply discrete_prod. eapply datatype_discrete. now exists I, R.
      eapply discrete_nat.
  - exists (fun l => c (I l)). intros.
    now rewrite <- (Hc (I x) y), HIR.
Qed.

Lemma EAS_list (p : list nat -> nat -> Prop) : enumerable (uncurry p) ->
                                      exists c : list nat -> nat, forall x y, W (c x) y <-> p x y.
Proof.
  intros.
  edestruct EAS_datatype with (p := p) as [c Hc]; eauto.
  - exact nil.
  - eapply enumerable_discrete_datatype.
    eapply discrete_list, discrete_nat.
    eauto.
  - exists c. firstorder.
Qed.

Lemma List_id : exists c_l, forall (l : list nat), forall x, W (c_l l) x <-> List.In x l.
Proof.
  eapply EAS_list.
  eapply decidable_enumerable. 2:eauto.
  eapply decidable_iff. econstructor.
  intros [x y]. cbn. exact _.
Qed.

Notation π1 := (fun! ⟨x, y⟩ => x).
Notation π2 := (fun! ⟨x, y⟩ => y).

Lemma enumerable_W : enumerable (fun '(x, y) => W x y).
Proof.
  exists (fun p => let (n,m) := unembed p in if φ n m is Some m then Some (n, m) else None).
  intros [n m].
  split.
  - intros H. destruct H as [n' H].
    exists (embed (n, n')). rewrite embedP. cbn. now rewrite H.
  - unfold W.
    intros [p H].
    destruct (unembed p) as [n' m'].
    exists m'.
    destruct (φ n' m') eqn:E; inversion H; now subst.
Qed.

Lemma W_maximal (p : nat -> Prop) :
  enumerable p -> p ⪯ₘ uncurry W.
Proof.
  intros Hp.
  destruct (do_EA p Hp) as [c Hc].
  exists (fun x => (c, x)). exact Hc.
Qed.

Lemma SMN' : forall f, exists k, forall c x, W c (f x) <-> W (k c) x.
Proof.
  intros f.
  eapply EAS.
  eapply enumerable_red with (q := uncurry W).
  - exists (fun '(x,y) => (x, f y)). now intros [x y].
  - eauto.
  - eapply discrete_prod; now eapply discrete_nat.
  - eapply enumerable_W.
Qed.

Lemma TT :
  forall f : nat -> { Q : list nat & truthtable},
    exists c : list nat -> nat, forall l x, W (c l) x <-> eval_tt (projT2 (f x)) (List.map (fun x => negb (inb (uncurry Nat.eqb) x l)) (projT1 (f x))) = false.
Proof.
  intros f.
  eapply EAS_list.
  eapply decidable_enumerable. 2:eauto.
  eapply decidable_iff. econstructor.
  intros [x y]. cbn. exact _.
Qed.

Tactic Notation "intros" "⟨" ident(n) "," ident(m) "⟩" :=
  let nm := fresh "nm" in
  let E := fresh "E" in
  intros nm; destruct (unembed nm) as [n m] eqn:E.

Definition K0 c := W c c.

Lemma K0_not_enumerable : ~ enumerable (compl K0).
Proof.
  intros [c Hc] % do_EA. specialize (Hc c).
  unfold K0, compl in Hc. tauto.
Qed.

Lemma K0_undecidable : ~ decidable (compl K0).
Proof.
  intros Hf % decidable_enumerable; eauto.
  now eapply K0_not_enumerable.
Qed.

Lemma W_uncurry_red:
  (fun! ⟨ n, m ⟩ => W n m) ⪯ₘ uncurry W.
Proof.
  exists (fun! ⟨n,m⟩ => (n,m)). intros nm. destruct (unembed nm) as [n m]. reflexivity.
Qed.

Lemma K0_red:
  K0 ⪯ₘ uncurry W.
Proof.
  exists (fun n => (n,n)). intros n. reflexivity.
Qed.

Lemma W_uncurry_red':
  uncurry W ⪯ₘ (fun! ⟨ n, m ⟩ => W n m).
Proof.
  exists (fun '(n,m) => ⟨n,m⟩). intros [n m]. now rewrite embedP.
Qed.

Global Hint Resolve discrete_prod discrete_nat : core.

Lemma W_not_enumerable : ~ enumerable (compl (uncurry W)).
Proof.
  eapply not_coenumerable; eauto.
  - eapply K0_red.
  - eapply K0_not_enumerable.
Qed.

Lemma K0_enum : enumerable K0.
Proof.
  eapply enumerable_red with (q := uncurry W).
  eapply K0_red. all:eauto.
  eapply enumerable_W.
Qed.

Lemma red_tt_not_red_m :
  compl K0 ⪯ₜₜ K0 /\ ~ compl K0 ⪯ₘ K0.
Proof.
  split.
  - eapply red_tt_complement.
  - intros H % enumerable_red.
    + now eapply K0_not_enumerable.
    + eauto.
    + eapply discrete_nat.
    + eapply K0_enum.
Qed.

Notation "m-complete p" := (forall q : nat -> Prop, enumerable q -> q ⪯ₘ p) (at level 10).

Lemma m_complete_W :
  m-complete (fun! ⟨n,m⟩ =>  W n m).
Proof.
  intros q [c Hc] % do_EA.
  exists (fun x => ⟨c,x⟩). intros x.
  now rewrite embedP.
Qed.

Lemma W_red_K0 : (fun! ⟨n,m⟩ =>  W n m) ⪯ₘ K0.
Proof.
  edestruct EAS with (p := fun! ⟨x,y⟩ => fun (z : nat) => W x y) as [c Hc].
  - eapply ReducibilityFacts.enumerable_red with (q := uncurry W); eauto.
    2: eapply enumerable_W. all:eauto.
    exists (fun '(xy,z) => (fun! ⟨x,y⟩ => (x,y)) xy). intros [xy z].
    cbn. now destruct (unembed xy) as [x y].
  - exists c. intros xy. unfold K0. rewrite <- (Hc xy (c xy)).
    now destruct (unembed xy) as [x y].
Qed.

Lemma m_complete_K0 : m-complete K0.
Proof.
  intros q Hq % m_complete_W.
  eapply red_m_transitive. exact Hq. exact W_red_K0.
Qed.

Lemma enum_iff (p : nat -> Prop) : enumerable p <-> semi_decidable p.
Proof.
  split.
  - intros H. eapply enumerable_semi_decidable. eapply discrete_nat. eassumption.
  - intros H. eapply semi_decidable_enumerable. eauto. eauto.
Qed.

Lemma generative_W :   generative (fun! ⟨ n, m ⟩ => W n m).
Proof.
  eapply unbounded_generative.
  intros x y; destruct (numbers.nat_eq_dec x y); eauto.
  destruct (do_EA (fun _ => True)) as [c_top H_top]. {
    eapply decidable_enumerable. 2:eauto. exists (fun _ => true). firstorder.
  }
  intros n. exists (map (fun m => ⟨c_top,m⟩) (seq 0 n)). split.
  now rewrite map_length, seq_length. split.
  eapply NoDup_map. intros ? ? E % (f_equal unembed). rewrite !embedP in E. congruence. eapply seq_NoDup.
  intros ? (? & <- & ?) % in_map_iff. rewrite embedP. firstorder.
Qed.


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

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

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

Require BitTerminationProofs.

(* Converted imports: *)

Require Coq.Init.Peano.
Require Data.Bits.
Require Data.Foldable.
Require Data.Maybe.
Require Data.Tuple.
Require GHC.Base.
Require GHC.Err.
Require GHC.Num.
Require GHC.Wf.
Require IntWord.
Import Data.Bits.Notations.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* Converted type declarations: *)

Definition Prefix :=
  IntWord.Int%type.

Definition Nat :=
  IntWord.Word%type.

Definition Mask :=
  IntWord.Int%type.

Definition Key :=
  IntWord.Int%type.

Definition BitMap :=
  IntWord.Word%type.

Inductive IntSet : Type
  := Bin : Prefix -> Mask -> IntSet -> IntSet -> IntSet
  |  Tip : Prefix -> BitMap -> IntSet
  |  Nil : IntSet.

Inductive Stack : Type
  := Push : Prefix -> IntSet -> Stack -> Stack
  |  Nada : Stack.

Instance Default__IntSet : GHC.Err.Default IntSet :=
  GHC.Err.Build_Default _ Nil.

Instance Default__Stack : GHC.Err.Default Stack := GHC.Err.Build_Default _ Nada.

(* Midamble *)

(** Additional definitions for termination proof *)

Fixpoint size_nat (t : IntSet) : nat :=
  match t with
  | Bin _ _ l r => S (size_nat l + size_nat r)%nat
  | Tip _ bm => 0
  | Nil => 0
  end.

Require Omega.
Ltac termination_by_omega :=
  Coq.Program.Tactics.program_simpl;
  simpl;Omega.omega.

(* Converted value declarations: *)

Definition tip : Prefix -> BitMap -> IntSet :=
  fun arg_0__ arg_1__ =>
    match arg_0__, arg_1__ with
    | _, num_2__ =>
        if num_2__ GHC.Base.== #0 : bool then Nil else
        match arg_0__, arg_1__ with
        | kx, bm => Tip kx bm
        end
    end.

Definition suffixBitMask : IntWord.Int :=
  #63.

Definition suffixOf : IntWord.Int -> IntWord.Int :=
  fun x => x Data.Bits..&.(**) suffixBitMask.

Definition splitRoot : IntSet -> list IntSet :=
  fun arg_0__ =>
    match arg_0__ with
    | Nil => nil
    | (Tip _ _ as x) => cons x nil
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool then cons r (cons l nil) else
        cons l (cons r nil)
    end.

Definition size : IntSet -> IntWord.Int :=
  let fix go arg_0__ arg_1__
            := match arg_0__, arg_1__ with
               | acc, Bin _ _ l r => go (go acc l) r
               | acc, Tip _ bm => acc GHC.Num.+ IntWord.bitcount #0 bm
               | acc, Nil => acc
               end in
  go #0.

Definition revNat : Nat -> Nat :=
  fun x1 =>
    let 'x2 := ((IntWord.shiftRWord x1 #1) Data.Bits..&.(**) #6148914691236517205)
                 Data.Bits..|.(**)
                 (IntWord.shiftLWord (x1 Data.Bits..&.(**) #6148914691236517205) #1) in
    let 'x3 := ((IntWord.shiftRWord x2 #2) Data.Bits..&.(**) #3689348814741910323)
                 Data.Bits..|.(**)
                 (IntWord.shiftLWord (x2 Data.Bits..&.(**) #3689348814741910323) #2) in
    let 'x4 := ((IntWord.shiftRWord x3 #4) Data.Bits..&.(**) #1085102592571150095)
                 Data.Bits..|.(**)
                 (IntWord.shiftLWord (x3 Data.Bits..&.(**) #1085102592571150095) #4) in
    let 'x5 := ((IntWord.shiftRWord x4 #8) Data.Bits..&.(**) #71777214294589695)
                 Data.Bits..|.(**)
                 (IntWord.shiftLWord (x4 Data.Bits..&.(**) #71777214294589695) #8) in
    let 'x6 := ((IntWord.shiftRWord x5 #16) Data.Bits..&.(**) #281470681808895)
                 Data.Bits..|.(**)
                 (IntWord.shiftLWord (x5 Data.Bits..&.(**) #281470681808895) #16) in
    (IntWord.shiftRWord x6 #32) Data.Bits..|.(**) (IntWord.shiftLWord x6 #32).

Definition prefixBitMask : IntWord.Int :=
  Data.Bits.complement suffixBitMask.

Definition prefixOf : IntWord.Int -> Prefix :=
  fun x => x Data.Bits..&.(**) prefixBitMask.

Definition null : IntSet -> bool :=
  fun arg_0__ => match arg_0__ with | Nil => true | _ => false end.

Definition nequal : IntSet -> IntSet -> bool :=
  fix nequal arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | Bin p1 m1 l1 r1, Bin p2 m2 l2 r2 =>
               orb (m1 GHC.Base./= m2) (orb (p1 GHC.Base./= p2) (orb (nequal l1 l2) (nequal r1
                                                                      r2)))
           | Tip kx1 bm1, Tip kx2 bm2 => orb (kx1 GHC.Base./= kx2) (bm1 GHC.Base./= bm2)
           | Nil, Nil => false
           | _, _ => true
           end.

Definition natFromInt :=
  IntWord.wordFromInt.

Definition shorter : Mask -> Mask -> bool :=
  fun m1 m2 => (natFromInt m1) GHC.Base.> (natFromInt m2).

Definition zero : IntWord.Int -> Mask -> bool :=
  fun i m => ((natFromInt i) Data.Bits..&.(**) (natFromInt m)) GHC.Base.== #0.

Definition lowestBitMask : Nat -> Nat :=
  fun x => x Data.Bits..&.(**) GHC.Num.negate x.

Definition intFromNat :=
  IntWord.intFromWord.

Definition maskW : Nat -> Nat -> Prefix :=
  fun i m =>
    intFromNat (i Data.Bits..&.(**)
                (Data.Bits.xor (Data.Bits.complement (m GHC.Num.- #1)) m)).

Definition mask : IntWord.Int -> Mask -> Prefix :=
  fun i m => maskW (natFromInt i) (natFromInt m).

Definition match_ : IntWord.Int -> Prefix -> Mask -> bool :=
  fun i p m => (mask i m) GHC.Base.== p.

Definition nomatch : IntWord.Int -> Prefix -> Mask -> bool :=
  fun i p m => (mask i m) GHC.Base./= p.

Definition isSubsetOf : IntSet -> IntSet -> bool :=
  fix isSubsetOf arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | (Bin p1 m1 l1 r1 as t1), Bin p2 m2 l2 r2 =>
               if shorter m1 m2 : bool then false else
               if shorter m2 m1 : bool
               then andb (match_ p1 p2 m2) (if zero p1 m2 : bool
                          then isSubsetOf t1 l2
                          else isSubsetOf t1 r2) else
               andb (p1 GHC.Base.== p2) (andb (isSubsetOf l1 l2) (isSubsetOf r1 r2))
           | _, _ =>
               match arg_0__, arg_1__ with
               | Bin _ _ _ _, _ => false
               | Tip kx1 bm1, Tip kx2 bm2 =>
                   andb (kx1 GHC.Base.== kx2) ((bm1 Data.Bits..&.(**) Data.Bits.complement bm2)
                         GHC.Base.==
                         #0)
               | (Tip kx _ as t1), Bin p m l r =>
                   if nomatch kx p m : bool then false else
                   if zero kx m : bool then isSubsetOf t1 l else
                   isSubsetOf t1 r
               | Tip _ _, Nil => false
               | Nil, _ => true
               end
           end.

Definition subsetCmp : IntSet -> IntSet -> comparison :=
  fix subsetCmp arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | (Bin p1 m1 l1 r1 as t1), Bin p2 m2 l2 r2 =>
               let subsetCmpEq :=
                 match pair (subsetCmp l1 l2) (subsetCmp r1 r2) with
                 | pair Gt _ => Gt
                 | pair _ Gt => Gt
                 | pair Eq Eq => Eq
                 | _ => Lt
                 end in
               let subsetCmpLt :=
                 if nomatch p1 p2 m2 : bool then Gt else
                 if zero p1 m2 : bool then subsetCmp t1 l2 else
                 subsetCmp t1 r2 in
               if shorter m1 m2 : bool then Gt else
               if shorter m2 m1 : bool
               then match subsetCmpLt with
                    | Gt => Gt
                    | _ => Lt
                    end else
               if p1 GHC.Base.== p2 : bool then subsetCmpEq else
               Gt
           | _, _ =>
               match arg_0__, arg_1__ with
               | Bin _ _ _ _, _ => Gt
               | Tip kx1 bm1, Tip kx2 bm2 =>
                   if kx1 GHC.Base./= kx2 : bool then Gt else
                   if bm1 GHC.Base.== bm2 : bool then Eq else
                   if (bm1 Data.Bits..&.(**) Data.Bits.complement bm2) GHC.Base.== #0 : bool
                   then Lt else
                   Gt
               | (Tip kx _ as t1), Bin p m l r =>
                   if nomatch kx p m : bool then Gt else
                   if zero kx m : bool then match subsetCmp t1 l with | Gt => Gt | _ => Lt end else
                   match subsetCmp t1 r with
                   | Gt => Gt
                   | _ => Lt
                   end
               | Tip _ _, Nil => Gt
               | Nil, Nil => Eq
               | Nil, _ => Lt
               end
           end.

Definition isProperSubsetOf : IntSet -> IntSet -> bool :=
  fun t1 t2 => match subsetCmp t1 t2 with | Lt => true | _ => false end.

Definition indexOfTheOnlyBit :=
  IntWord.indexOfTheOnlyBit.

Definition lowestBitSet : Nat -> IntWord.Int :=
  fun x => indexOfTheOnlyBit (lowestBitMask x).

Definition unsafeFindMin : IntSet -> option Key :=
  fix unsafeFindMin arg_0__
        := match arg_0__ with
           | Nil => None
           | Tip kx bm => Some (kx GHC.Num.+ lowestBitSet bm)
           | Bin _ _ l _ => unsafeFindMin l
           end.

Definition highestBitSet : Nat -> IntWord.Int :=
  fun x => indexOfTheOnlyBit (IntWord.highestBitMask x).

Definition unsafeFindMax : IntSet -> option Key :=
  fix unsafeFindMax arg_0__
        := match arg_0__ with
           | Nil => None
           | Tip kx bm => Some (kx GHC.Num.+ highestBitSet bm)
           | Bin _ _ _ r => unsafeFindMax r
           end.

Program Definition foldrBits {a}
           : IntWord.Int -> (IntWord.Int -> a -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               IntWord.wordTonat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) ((f ((prefix GHC.Num.+ (#64 GHC.Num.- #1))
                                                                          GHC.Num.-
                                                                          bi)) acc)
                                   end
                               end) in
            go (revNat bitmap) z.
Admit Obligations.

Program Definition foldr'Bits {a}
           : IntWord.Int -> (IntWord.Int -> a -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               IntWord.wordTonat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) ((f ((prefix GHC.Num.+ (#64 GHC.Num.- #1))
                                                                          GHC.Num.-
                                                                          bi)) acc)
                                   end
                               end) in
            go (revNat bitmap) z.
Admit Obligations.

Definition foldr' {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldr'Bits kx f z' bm
                 | z', Bin _ _ l r => go (go z' r) l
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z l) r else go (go z r) l
      | _ => go z t
      end.

Definition foldr {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldrBits kx f z' bm
                 | z', Bin _ _ l r => go (go z' r) l
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z l) r else go (go z r) l
      | _ => go z t
      end.

Definition foldrFB {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  foldr.

Definition toAscList : IntSet -> list Key :=
  foldr cons nil.

Definition toList : IntSet -> list Key :=
  toAscList.

Program Definition foldlBits {a}
           : IntWord.Int -> (a -> IntWord.Int -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               IntWord.wordTonat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) (f acc (prefix GHC.Num.+ bi))
                                   end
                               end) in
            go bitmap z.
Admit Obligations.

Program Definition foldl'Bits {a}
           : IntWord.Int -> (a -> IntWord.Int -> a) -> a -> Nat -> a :=
          fun prefix f z bitmap =>
            let go :=
              GHC.Wf.wfFix2 Coq.Init.Peano.lt (fun arg_0__ arg_1__ =>
                               IntWord.wordTonat arg_0__) _ (fun arg_0__ arg_1__ go =>
                               match arg_0__, arg_1__ with
                               | num_2__, acc =>
                                   if Bool.Sumbool.sumbool_of_bool (num_2__ GHC.Base.== #0) then acc else
                                   match arg_0__, arg_1__ with
                                   | bm, acc =>
                                       let bitmask := lowestBitMask bm in
                                       let bi := indexOfTheOnlyBit bitmask in
                                       go (Data.Bits.xor bm bitmask) (f acc (prefix GHC.Num.+ bi))
                                   end
                               end) in
            go bitmap z.
Admit Obligations.

Definition foldl' {a} : (a -> Key -> a) -> a -> IntSet -> a :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldl'Bits kx f z' bm
                 | z', Bin _ _ l r => go (go z' l) r
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z r) l else go (go z l) r
      | _ => go z t
      end.

Definition foldl {a} : (a -> Key -> a) -> a -> IntSet -> a :=
  fun f z =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | z', Nil => z'
                 | z', Tip kx bm => foldlBits kx f z' bm
                 | z', Bin _ _ l r => go (go z' l) r
                 end in
    fun t =>
      match t with
      | Bin _ m l r => if m GHC.Base.< #0 : bool then go (go z r) l else go (go z l) r
      | _ => go z t
      end.

Definition foldlFB {a} : (a -> Key -> a) -> a -> IntSet -> a :=
  foldl.

Definition toDescList : IntSet -> list Key :=
  foldl (GHC.Base.flip cons) nil.

Definition fold {b} : (Key -> b -> b) -> b -> IntSet -> b :=
  foldr.

Definition equal : IntSet -> IntSet -> bool :=
  fix equal arg_0__ arg_1__
        := match arg_0__, arg_1__ with
           | Bin p1 m1 l1 r1, Bin p2 m2 l2 r2 =>
               andb (m1 GHC.Base.== m2) (andb (p1 GHC.Base.== p2) (andb (equal l1 l2) (equal r1
                                                                         r2)))
           | Tip kx1 bm1, Tip kx2 bm2 => andb (kx1 GHC.Base.== kx2) (bm1 GHC.Base.== bm2)
           | Nil, Nil => true
           | _, _ => false
           end.

Definition empty : IntSet :=
  Nil.

Definition elems : IntSet -> list Key :=
  toAscList.

Program Fixpoint disjoint (arg_0__ : IntSet) (arg_1__ : IntSet)
                          {measure (size_nat arg_0__ + size_nat arg_1__)} : bool
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let disjoint2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then true else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2) then disjoint t1 l2 else
                            disjoint t1 r2 in
                          let disjoint1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then true else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1) then disjoint l1 t2 else
                            disjoint r1 t2 in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then disjoint1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then disjoint2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then andb (disjoint l1 l2) (disjoint r1 r2) else
                          true
                      | (Bin _ _ _ _ as t1), Tip kx2 bm2 =>
                          let fix disjointBM arg_11__
                                    := match arg_11__ with
                                       | Bin p1 m1 l1 r1 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx2 p1 m1) then true else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx2 m1) then disjointBM l1 else
                                           disjointBM r1
                                       | Tip kx1 bm1 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then (bm1 Data.Bits..&.(**) bm2) GHC.Base.== #0 else
                                           true
                                       | Nil => true
                                       end in
                          disjointBM t1
                      | Bin _ _ _ _, Nil => true
                      | Tip kx1 bm1, t2 =>
                          let fix disjointBM arg_18__
                                    := match arg_18__ with
                                       | Bin p2 m2 l2 r2 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx1 p2 m2) then true else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx1 m2) then disjointBM l2 else
                                           disjointBM r2
                                       | Tip kx2 bm2 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then (bm1 Data.Bits..&.(**) bm2) GHC.Base.== #0 else
                                           true
                                       | Nil => true
                                       end in
                          disjointBM t2
                      | Nil, _ => true
                      end.
Solve Obligations with (termination_by_omega).

Definition branchMask : Prefix -> Prefix -> Mask :=
  fun p1 p2 =>
    intFromNat (IntWord.highestBitMask (Data.Bits.xor (natFromInt p1) (natFromInt
                                                       p2))).

Definition link : Prefix -> IntSet -> Prefix -> IntSet -> IntSet :=
  fun p1 t1 p2 t2 =>
    let m := branchMask p1 p2 in
    let p := mask p1 m in if zero p1 m : bool then Bin p m t1 t2 else Bin p m t2 t1.

Definition insertBM : Prefix -> BitMap -> IntSet -> IntSet :=
  fix insertBM arg_0__ arg_1__ arg_2__
        := match arg_0__, arg_1__, arg_2__ with
           | kx, bm, (Bin p m l r as t) =>
               if nomatch kx p m : bool then link kx (Tip kx bm) p t else
               if zero kx m : bool then Bin p m (insertBM kx bm l) r else
               Bin p m l (insertBM kx bm r)
           | kx, bm, (Tip kx' bm' as t) =>
               if kx' GHC.Base.== kx : bool then Tip kx' (bm Data.Bits..|.(**) bm') else
               link kx (Tip kx bm) kx' t
           | kx, bm, Nil => Tip kx bm
           end.

Program Fixpoint union (arg_0__ : IntSet) (arg_1__ : IntSet) {measure (size_nat
                        arg_0__ +
                        size_nat arg_1__)} : IntSet
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let union2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then link p1 t1 p2 t2 else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2)
                            then Bin p2 m2 (union t1 l2) r2 else
                            Bin p2 m2 l2 (union t1 r2) in
                          let union1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then link p1 t1 p2 t2 else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1)
                            then Bin p1 m1 (union l1 t2) r1 else
                            Bin p1 m1 l1 (union r1 t2) in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then union1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then union2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then Bin p1 m1 (union l1 l2) (union r1 r2) else
                          link p1 t1 p2 t2
                      | (Bin _ _ _ _ as t), Tip kx bm => insertBM kx bm t
                      | (Bin _ _ _ _ as t), Nil => t
                      | Tip kx bm, t => insertBM kx bm t
                      | Nil, t => t
                      end.
Solve Obligations with (termination_by_omega).

Definition unions {f} `{Data.Foldable.Foldable f} : f IntSet -> IntSet :=
  fun xs => Data.Foldable.foldl' union empty xs.

Definition bitmapOfSuffix : IntWord.Int -> BitMap :=
  fun s => IntWord.shiftLWord #1 s.

Definition bitmapOf : IntWord.Int -> BitMap :=
  fun x => bitmapOfSuffix (suffixOf x).

Definition insert : Key -> IntSet -> IntSet :=
  fun x => insertBM (prefixOf x) (bitmapOf x).

Definition fromList : list Key -> IntSet :=
  fun xs => let ins := fun t x => insert x t in Data.Foldable.foldl' ins empty xs.

Definition map : (Key -> Key) -> IntSet -> IntSet :=
  fun f => fromList GHC.Base.∘ (GHC.Base.map f GHC.Base.∘ toList).

Definition lookupGE : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMin l
                          else unsafeFindMin def else
                     if zero x m : bool then go r l else
                     go def r
                 | def, Tip kx bm =>
                     let maskGE := (GHC.Num.negate (bitmapOf x)) Data.Bits..&.(**) bm in
                     if prefixOf x GHC.Base.< kx : bool then Some (kx GHC.Num.+ lowestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskGE GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ lowestBitSet maskGE) else
                     unsafeFindMin def
                 | def, Nil => unsafeFindMin def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go Nil l
             else go l r else
        j_12__
    | _ => j_12__
    end.

Definition lookupGT : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMin l
                          else unsafeFindMin def else
                     if zero x m : bool then go r l else
                     go def r
                 | def, Tip kx bm =>
                     let maskGT :=
                       (GHC.Num.negate (IntWord.shiftLWord (bitmapOf x) #1)) Data.Bits..&.(**) bm in
                     if prefixOf x GHC.Base.< kx : bool then Some (kx GHC.Num.+ lowestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskGT GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ lowestBitSet maskGT) else
                     unsafeFindMin def
                 | def, Nil => unsafeFindMin def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go Nil l
             else go l r else
        j_12__
    | _ => j_12__
    end.

Definition lookupLE : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMax def
                          else unsafeFindMax r else
                     if zero x m : bool then go def l else
                     go l r
                 | def, Tip kx bm =>
                     let maskLE :=
                       ((IntWord.shiftLWord (bitmapOf x) #1) GHC.Num.- #1) Data.Bits..&.(**) bm in
                     if prefixOf x GHC.Base.> kx : bool
                     then Some (kx GHC.Num.+ highestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskLE GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ highestBitSet maskLE) else
                     unsafeFindMax def
                 | def, Nil => unsafeFindMax def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go r l
             else go Nil r else
        j_12__
    | _ => j_12__
    end.

Definition lookupLT : Key -> IntSet -> option Key :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | def, Bin p m l r =>
                     if nomatch x p m : bool
                     then if x GHC.Base.< p : bool
                          then unsafeFindMax def
                          else unsafeFindMax r else
                     if zero x m : bool then go def l else
                     go l r
                 | def, Tip kx bm =>
                     let maskLT := (bitmapOf x GHC.Num.- #1) Data.Bits..&.(**) bm in
                     if prefixOf x GHC.Base.> kx : bool
                     then Some (kx GHC.Num.+ highestBitSet bm) else
                     if andb (prefixOf x GHC.Base.== kx) (maskLT GHC.Base./= #0) : bool
                     then Some (kx GHC.Num.+ highestBitSet maskLT) else
                     unsafeFindMax def
                 | def, Nil => unsafeFindMax def
                 end in
    let j_12__ := go Nil t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then go r l
             else go Nil r else
        j_12__
    | _ => j_12__
    end.

Definition member : Key -> IntSet -> bool :=
  fun x =>
    let fix go arg_0__
              := match arg_0__ with
                 | Bin p m l r =>
                     if nomatch x p m : bool then false else
                     if zero x m : bool then go l else
                     go r
                 | Tip y bm =>
                     andb (prefixOf x GHC.Base.== y) ((bitmapOf x Data.Bits..&.(**) bm) GHC.Base./=
                           #0)
                 | Nil => false
                 end in
    go.

Definition notMember : Key -> IntSet -> bool :=
  fun k => negb GHC.Base.∘ member k.

Definition singleton : Key -> IntSet :=
  fun x => Tip (prefixOf x) (bitmapOf x).

Definition split : Key -> IntSet -> (IntSet * IntSet)%type :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | x', (Bin p m l r as t') =>
                     if match_ x' p m : bool
                     then if zero x' m : bool
                          then let 'pair lt gt := go x' l in
                               pair lt (union gt r)
                          else let 'pair lt gt := go x' r in
                               pair (union lt l) gt else
                     if x' GHC.Base.< p : bool
                     then (pair Nil t')
                     else (pair t' Nil)
                 | x', (Tip kx' bm as t') =>
                     let lowerBitmap := bitmapOf x' GHC.Num.- #1 in
                     let higherBitmap := Data.Bits.complement (lowerBitmap GHC.Num.+ bitmapOf x') in
                     if kx' GHC.Base.> x' : bool then (pair Nil t') else
                     if kx' GHC.Base.< prefixOf x' : bool then (pair t' Nil) else
                     pair (tip kx' (bm Data.Bits..&.(**) lowerBitmap)) (tip kx' (bm Data.Bits..&.(**)
                                                                                higherBitmap))
                 | _, Nil => (pair Nil Nil)
                 end in
    let j_21__ := let 'pair lt gt := go x t in pair lt gt in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then let 'pair lt gt := go x l in
                  let lt' := union lt r in pair lt' gt
             else let 'pair lt gt := go x r in
                  let gt' := union gt l in pair lt gt' else
        j_21__
    | _ => j_21__
    end.

Definition splitMember : Key -> IntSet -> (IntSet * bool * IntSet)%type :=
  fun x t =>
    let fix go arg_0__ arg_1__
              := match arg_0__, arg_1__ with
                 | x', (Bin p m l r as t') =>
                     if match_ x' p m : bool
                     then if zero x' m : bool
                          then let 'pair (pair lt fnd) gt := go x' l in
                               pair (pair lt fnd) (union gt r)
                          else let 'pair (pair lt fnd) gt := go x' r in
                               pair (pair (union lt l) fnd) gt else
                     if x' GHC.Base.< p : bool
                     then pair (pair Nil false) t'
                     else pair (pair t' false) Nil
                 | x', (Tip kx' bm as t') =>
                     let bitmapOfx' := bitmapOf x' in
                     let lowerBitmap := bitmapOfx' GHC.Num.- #1 in
                     let higherBitmap := Data.Bits.complement (lowerBitmap GHC.Num.+ bitmapOfx') in
                     if kx' GHC.Base.> x' : bool then pair (pair Nil false) t' else
                     if kx' GHC.Base.< prefixOf x' : bool then pair (pair t' false) Nil else
                     let gt := tip kx' (bm Data.Bits..&.(**) higherBitmap) in
                     let found := (bm Data.Bits..&.(**) bitmapOfx') GHC.Base./= #0 in
                     let lt := tip kx' (bm Data.Bits..&.(**) lowerBitmap) in pair (pair lt found) gt
                 | _, Nil => pair (pair Nil false) Nil
                 end in
    let j_22__ := go x t in
    match t with
    | Bin _ m l r =>
        if m GHC.Base.< #0 : bool
        then if x GHC.Base.>= #0 : bool
             then let 'pair (pair lt fnd) gt := go x l in
                  let lt' := union lt r in pair (pair lt' fnd) gt
             else let 'pair (pair lt fnd) gt := go x r in
                  let gt' := union gt l in pair (pair lt fnd) gt' else
        j_22__
    | _ => j_22__
    end.

Definition bin : Prefix -> Mask -> IntSet -> IntSet -> IntSet :=
  fun arg_0__ arg_1__ arg_2__ arg_3__ =>
    match arg_0__, arg_1__, arg_2__, arg_3__ with
    | _, _, l, Nil => l
    | _, _, Nil, r => r
    | p, m, l, r => Bin p m l r
    end.

Definition deleteBM : Prefix -> BitMap -> IntSet -> IntSet :=
  fix deleteBM arg_0__ arg_1__ arg_2__
        := match arg_0__, arg_1__, arg_2__ with
           | kx, bm, (Bin p m l r as t) =>
               if nomatch kx p m : bool then t else
               if zero kx m : bool then bin p m (deleteBM kx bm l) r else
               bin p m l (deleteBM kx bm r)
           | kx, bm, (Tip kx' bm' as t) =>
               if kx' GHC.Base.== kx : bool
               then tip kx (bm' Data.Bits..&.(**) Data.Bits.complement bm) else
               t
           | _, _, Nil => Nil
           end.

Definition delete : Key -> IntSet -> IntSet :=
  fun x => deleteBM (prefixOf x) (bitmapOf x).

Program Fixpoint difference (arg_0__ : IntSet) (arg_1__ : IntSet)
                            {measure (size_nat arg_0__ + size_nat arg_1__)} : IntSet
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let difference2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then t1 else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2) then difference t1 l2 else
                            difference t1 r2 in
                          let difference1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then t1 else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1)
                            then bin p1 m1 (difference l1 t2) r1 else
                            bin p1 m1 l1 (difference r1 t2) in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then difference1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then difference2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then bin p1 m1 (difference l1 l2) (difference r1 r2) else
                          t1
                      | (Bin _ _ _ _ as t), Tip kx bm => deleteBM kx bm t
                      | (Bin _ _ _ _ as t), Nil => t
                      | (Tip kx bm as t1), t2 =>
                          let fix differenceTip arg_12__
                                    := match arg_12__ with
                                       | Bin p2 m2 l2 r2 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx p2 m2) then t1 else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx m2) then differenceTip l2 else
                                           differenceTip r2
                                       | Tip kx2 bm2 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx GHC.Base.== kx2)
                                           then tip kx (bm Data.Bits..&.(**) Data.Bits.complement bm2) else
                                           t1
                                       | Nil => t1
                                       end in
                          differenceTip t2
                      | Nil, _ => Nil
                      end.
Solve Obligations with (termination_by_omega).

Definition op_zrzr__ : IntSet -> IntSet -> IntSet :=
  fun m1 m2 => difference m1 m2.

Notation "'_\\_'" := (op_zrzr__).

Infix "\\" := (_\\_) (at level 99).

Definition filter : (Key -> bool) -> IntSet -> IntSet :=
  fix filter predicate t
        := let bitPred :=
             fun kx bm bi =>
               if predicate (kx GHC.Num.+ bi) : bool
               then bm Data.Bits..|.(**) bitmapOfSuffix bi else
               bm in
           match t with
           | Bin p m l r => bin p m (filter predicate l) (filter predicate r)
           | Tip kx bm => tip kx (foldl'Bits #0 (bitPred kx) #0 bm)
           | Nil => Nil
           end.

Program Fixpoint intersection (arg_0__ : IntSet) (arg_1__ : IntSet)
                              {measure (size_nat arg_0__ + size_nat arg_1__)} : IntSet
                   := match arg_0__, arg_1__ with
                      | (Bin p1 m1 l1 r1 as t1), (Bin p2 m2 l2 r2 as t2) =>
                          let intersection2 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p1 p2 m2) then Nil else
                            if Bool.Sumbool.sumbool_of_bool (zero p1 m2) then intersection t1 l2 else
                            intersection t1 r2 in
                          let intersection1 :=
                            if Bool.Sumbool.sumbool_of_bool (nomatch p2 p1 m1) then Nil else
                            if Bool.Sumbool.sumbool_of_bool (zero p2 m1) then intersection l1 t2 else
                            intersection r1 t2 in
                          if Bool.Sumbool.sumbool_of_bool (shorter m1 m2) then intersection1 else
                          if Bool.Sumbool.sumbool_of_bool (shorter m2 m1) then intersection2 else
                          if Bool.Sumbool.sumbool_of_bool (p1 GHC.Base.== p2)
                          then bin p1 m1 (intersection l1 l2) (intersection r1 r2) else
                          Nil
                      | (Bin _ _ _ _ as t1), Tip kx2 bm2 =>
                          let fix intersectBM arg_11__
                                    := match arg_11__ with
                                       | Bin p1 m1 l1 r1 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx2 p1 m1) then Nil else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx2 m1) then intersectBM l1 else
                                           intersectBM r1
                                       | Tip kx1 bm1 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then tip kx1 (bm1 Data.Bits..&.(**) bm2) else
                                           Nil
                                       | Nil => Nil
                                       end in
                          intersectBM t1
                      | Bin _ _ _ _, Nil => Nil
                      | Tip kx1 bm1, t2 =>
                          let fix intersectBM arg_18__
                                    := match arg_18__ with
                                       | Bin p2 m2 l2 r2 =>
                                           if Bool.Sumbool.sumbool_of_bool (nomatch kx1 p2 m2) then Nil else
                                           if Bool.Sumbool.sumbool_of_bool (zero kx1 m2) then intersectBM l2 else
                                           intersectBM r2
                                       | Tip kx2 bm2 =>
                                           if Bool.Sumbool.sumbool_of_bool (kx1 GHC.Base.== kx2)
                                           then tip kx1 (bm1 Data.Bits..&.(**) bm2) else
                                           Nil
                                       | Nil => Nil
                                       end in
                          intersectBM t2
                      | Nil, _ => Nil
                      end.
Solve Obligations with (termination_by_omega).

Definition maxView : IntSet -> option (Key * IntSet)%type :=
  fun t =>
    let fix go arg_0__
              := match arg_0__ with
                 | Bin p m l r => let 'pair result r' := go r in pair result (bin p m l r')
                 | Tip kx bm =>
                     let 'bi := highestBitSet bm in
                     pair (kx GHC.Num.+ bi) (tip kx (bm Data.Bits..&.(**)
                                                     Data.Bits.complement (bitmapOfSuffix bi)))
                 | Nil => GHC.Err.error (GHC.Base.hs_string__ "maxView Nil")
                 end in
    let j_12__ := Some (go t) in
    match t with
    | Nil => None
    | Bin p m l r =>
        if m GHC.Base.< #0 : bool
        then let 'pair result l' := go l in
             Some (pair result (bin p m l' r)) else
        j_12__
    | _ => j_12__
    end.

Definition deleteMax : IntSet -> IntSet :=
  Data.Maybe.maybe Nil Data.Tuple.snd GHC.Base.∘ maxView.

Definition minView : IntSet -> option (Key * IntSet)%type :=
  fun t =>
    let fix go arg_0__
              := match arg_0__ with
                 | Bin p m l r => let 'pair result l' := go l in pair result (bin p m l' r)
                 | Tip kx bm =>
                     let 'bi := lowestBitSet bm in
                     pair (kx GHC.Num.+ bi) (tip kx (bm Data.Bits..&.(**)
                                                     Data.Bits.complement (bitmapOfSuffix bi)))
                 | Nil => GHC.Err.error (GHC.Base.hs_string__ "minView Nil")
                 end in
    let j_12__ := Some (go t) in
    match t with
    | Nil => None
    | Bin p m l r =>
        if m GHC.Base.< #0 : bool
        then let 'pair result r' := go r in
             Some (pair result (bin p m l r')) else
        j_12__
    | _ => j_12__
    end.

Definition deleteMin : IntSet -> IntSet :=
  Data.Maybe.maybe Nil Data.Tuple.snd GHC.Base.∘ minView.

Definition partition : (Key -> bool) -> IntSet -> (IntSet * IntSet)%type :=
  fun predicate0 t0 =>
    let fix go predicate t
              := let bitPred :=
                   fun kx bm bi =>
                     if predicate (kx GHC.Num.+ bi) : bool
                     then bm Data.Bits..|.(**) bitmapOfSuffix bi else
                     bm in
                 match t with
                 | Bin p m l r =>
                     let 'pair r1 r2 := go predicate r in
                     let 'pair l1 l2 := go predicate l in
                     pair (bin p m l1 r1) (bin p m l2 r2)
                 | Tip kx bm =>
                     let bm1 := foldl'Bits #0 (bitPred kx) #0 bm in
                     pair (tip kx bm1) (tip kx (Data.Bits.xor bm bm1))
                 | Nil => (pair Nil Nil)
                 end in
    id (go predicate0 t0).

(* Skipping all instances of class `Control.DeepSeq.NFData', including
   `Data.IntSet.InternalWord.NFData__IntSet' *)

(* Skipping all instances of class `GHC.Read.Read', including
   `Data.IntSet.InternalWord.Read__IntSet' *)

(* Skipping all instances of class `GHC.Show.Show', including
   `Data.IntSet.InternalWord.Show__IntSet' *)

Local Definition Ord__IntSet_compare : IntSet -> IntSet -> comparison :=
  fun s1 s2 => GHC.Base.compare (toAscList s1) (toAscList s2).

Local Definition Ord__IntSet_op_zl__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base.== Lt.

Local Definition Ord__IntSet_op_zlze__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base./= Gt.

Local Definition Ord__IntSet_op_zg__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base.== Gt.

Local Definition Ord__IntSet_op_zgze__ : IntSet -> IntSet -> bool :=
  fun x y => Ord__IntSet_compare x y GHC.Base./= Lt.

Local Definition Ord__IntSet_max : IntSet -> IntSet -> IntSet :=
  fun x y => if Ord__IntSet_op_zlze__ x y : bool then y else x.

Local Definition Ord__IntSet_min : IntSet -> IntSet -> IntSet :=
  fun x y => if Ord__IntSet_op_zlze__ x y : bool then x else y.

Local Definition Eq___IntSet_op_zeze__ : IntSet -> IntSet -> bool :=
  fun t1 t2 => equal t1 t2.

Local Definition Eq___IntSet_op_zsze__ : IntSet -> IntSet -> bool :=
  fun t1 t2 => nequal t1 t2.

Program Instance Eq___IntSet : GHC.Base.Eq_ IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zeze____ := Eq___IntSet_op_zeze__ ;
           GHC.Base.op_zsze____ := Eq___IntSet_op_zsze__ |}.

Program Instance Ord__IntSet : GHC.Base.Ord IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zl____ := Ord__IntSet_op_zl__ ;
           GHC.Base.op_zlze____ := Ord__IntSet_op_zlze__ ;
           GHC.Base.op_zg____ := Ord__IntSet_op_zg__ ;
           GHC.Base.op_zgze____ := Ord__IntSet_op_zgze__ ;
           GHC.Base.compare__ := Ord__IntSet_compare ;
           GHC.Base.max__ := Ord__IntSet_max ;
           GHC.Base.min__ := Ord__IntSet_min |}.

(* Skipping all instances of class `Data.Data.Data', including
   `Data.IntSet.InternalWord.Data__IntSet' *)

Local Definition Semigroup__IntSet_op_zlzlzgzg__ : IntSet -> IntSet -> IntSet :=
  union.

Program Instance Semigroup__IntSet : GHC.Base.Semigroup IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.op_zlzlzgzg____ := Semigroup__IntSet_op_zlzlzgzg__ |}.

Local Definition Monoid__IntSet_mappend : IntSet -> IntSet -> IntSet :=
  _GHC.Base.<<>>_.

Local Definition Monoid__IntSet_mconcat : list IntSet -> IntSet :=
  unions.

Local Definition Monoid__IntSet_mempty : IntSet :=
  empty.

Program Instance Monoid__IntSet : GHC.Base.Monoid IntSet :=
  fun _ k__ =>
    k__ {| GHC.Base.mappend__ := Monoid__IntSet_mappend ;
           GHC.Base.mconcat__ := Monoid__IntSet_mconcat ;
           GHC.Base.mempty__ := Monoid__IntSet_mempty |}.

(* Skipping all instances of class `GHC.Exts.IsList', including
   `Data.IntSet.InternalWord.IsList__IntSet' *)

Module Notations.
Notation "'_Data.IntSet.InternalWord.\\_'" := (op_zrzr__).
Infix "Data.IntSet.InternalWord.\\" := (_\\_) (at level 99).
End Notations.

(* External variables:
     Bool.Sumbool.sumbool_of_bool Eq Gt Lt None Some andb bool comparison cons false
     id list negb nil op_zp__ op_zt__ option orb pair size_nat true Coq.Init.Peano.lt
     Data.Bits.complement Data.Bits.op_zizazi__ Data.Bits.op_zizbzi__ Data.Bits.xor
     Data.Foldable.Foldable Data.Foldable.foldl' Data.Maybe.maybe Data.Tuple.snd
     GHC.Base.Eq_ GHC.Base.Monoid GHC.Base.Ord GHC.Base.Semigroup GHC.Base.compare
     GHC.Base.compare__ GHC.Base.flip GHC.Base.map GHC.Base.mappend__ GHC.Base.max__
     GHC.Base.mconcat__ GHC.Base.mempty__ GHC.Base.min__ GHC.Base.op_z2218U__
     GHC.Base.op_zeze__ GHC.Base.op_zeze____ GHC.Base.op_zg__ GHC.Base.op_zg____
     GHC.Base.op_zgze__ GHC.Base.op_zgze____ GHC.Base.op_zl__ GHC.Base.op_zl____
     GHC.Base.op_zlze____ GHC.Base.op_zlzlzgzg__ GHC.Base.op_zlzlzgzg____
     GHC.Base.op_zsze__ GHC.Base.op_zsze____ GHC.Err.Build_Default GHC.Err.Default
     GHC.Err.error GHC.Num.fromInteger GHC.Num.negate GHC.Num.op_zm__ GHC.Num.op_zp__
     GHC.Wf.wfFix2 IntWord.Int IntWord.Word IntWord.bitcount IntWord.highestBitMask
     IntWord.indexOfTheOnlyBit IntWord.intFromWord IntWord.shiftLWord
     IntWord.shiftRWord IntWord.wordFromInt IntWord.wordTonat
*)


(** Monadic Parser Combinators *)
(** モナディック パーサー コンビネータ *)

(* @suharahiromichi 2014_01_08 *)

(** paeser T の定義は sf/ImpParser_J を使用した。
    コンビネータの型は pcl.pdf、処理の内容は ocamlAda を参考にした。*)

(* http://proofcafe.org/sf/ImpParser_J.html *)
(* https://github.com/yoshihiro503/ocamlAda/blob/master/src/parserMonad.ml *)
(* https://ocaml.janestreet.com/files/pcl.pdf *)

Require Import ssreflect ssrbool ssrnat seq eqtype.
Require Import ssrfun.
Require Import String.
Require Import Ascii.

(** (1) 字句解析 *)
Definition isWhite (c : ascii) : bool :=
  let n := nat_of_ascii c in
  (n == 32) ||                              (* space *)
            (n ==  9) ||                    (* tab *)
            (n == 10) ||                    (* linefeed *)
            (n == 13).                      (* Carriage return. *)

Definition isLowerAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
  (97 <= n) && (n <= 122).

Definition isAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
  (65 <= n) && (n <= 90) ||
            (97 <= n) && (n <= 122).

Definition isDigit (c : ascii) : bool :=
  let n := nat_of_ascii c in
  (48 <= n) && (n <= 57).

Inductive chartype := white | alpha | digit | other.

Definition classifyChar (c : ascii) : chartype :=
  if isWhite c then
    white
  else if isAlpha c then
    alpha
  else if isDigit c then
    digit
  else
    other.

Fixpoint list_of_string (s : string) : list ascii :=
  match s with
  | EmptyString => [::]
  | String c s => c :: (list_of_string s)
  end.

Fixpoint string_of_list (xs : list ascii) : string :=
  foldr String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls : chartype) (acc xs : list ascii)
                       : list (list ascii) :=
  let tk :=
      match acc with
        | [::] => [::]
        | _::_ => (rev acc) :: [::]
      end in
  match xs with
    | [::] => tk
    | (x::xs') =>
      match cls, classifyChar x, x with
        | _, _, "("      => tk ++ [:: "("] :: (tokenize_helper other [::] xs')
        | _, _, ")"      => tk ++ [:: ")"] :: (tokenize_helper other [::] xs')
        | _, white, _    => tk ++ (tokenize_helper white [::] xs')
        | alpha,alpha,x  => tokenize_helper alpha (x::acc) xs'
        | digit,digit,x  => tokenize_helper digit (x::acc) xs'
        | other,other,x  => tokenize_helper other (x::acc) xs'
        | _,tp,x         => tk ++ (tokenize_helper tp [:: x] xs')
      end
  end %char.
(* "("と")"だけ別になっているのは、"("と")"の前後にはスペースがなくても、
 トークンの区切りと解釈するため。　他の記号はスペースが必要。
 つまり、"--" は"-"ふたつとは解釈されないが、"-("は、"-"と"("と区別される。 *)

(* ***トークンのパースのメイン*** *)
Definition tokenize (s : string) : list string :=
  map string_of_list (tokenize_helper white [::] (list_of_string s)).

Example tokenize_ex1 :
  tokenize "abc12==3  223*(3+(a+c))"%string
  = [:: "abc"; "12"; "=="; "3"; "223";
       "*"; "("; "3"; "+"; "(";
       "a"; "+"; "c"; ")"; ")" ]%string.
Proof. reflexivity. Qed.

(** Option と Error *)
Inductive optionE (T : Type) : Type :=
  | SomeE : T -> optionE T
  | NoneE : string -> optionE T.

Implicit Arguments SomeE [[T]].
Implicit Arguments NoneE [[T]].

(** (2) Symbol Table *)
Fixpoint forallb {A} f (l:list A) : bool :=
  match l with
    | nil => true
    | a::l => f a && forallb f l
  end.

Fixpoint build_symtable (xs : list token) (n : nat) : (token -> nat) :=
  match xs with
  | [::] => (fun s => n)
  | x::xs =>
    if (forallb isLowerAlpha (list_of_string x)) then
      (fun s => if string_dec s x then n else (build_symtable xs (S n) s))
     else
       build_symtable xs n
  end.

Eval compute in build_symtable [::] 0.      (* 空のシンボルテーブル *)
Eval compute in build_symtable [:: "aaa"; "+"; "bbb"; "+"; "ccc"]%string
                               0 "aaa"%string . (* 0 *)
Eval compute in build_symtable [:: "aaa"; "+"; "bbb"; "+"; "ccc"]%string
                               0 "bbb"%string. (* 1 *)
Eval compute in build_symtable [:: "aaa"; "+"; "bbb"; "+"; "ccc"]%string
                               0 "ccc"%string. (* 2 *)
Eval compute in build_symtable [:: "aaa"; "+"; "bbb"; "+"; "ccc"]%string
                               0 "xxx"%string. (* 3 *)

(** (3) パーサ コンビネータ *)
Definition parser (T : Type) :=
  list token -> optionE (T * list token).
(* Tとしてとるものは、unit(予約語)、id、nat、bexp、aexp、com
   bexpがどこからくるのかは、自明ではない。 *)
Print unit.
Check unit.
Check (parser unit).
Check (parser nat).

(* ret : T -> parser T *)
Definition ret {T : Type} (t : T) : parser T :=
  fun (xs : list token) => SomeE (t, xs).
Check ret.

(* bind : parser T -> (T -> parser S) -> parser S *)
Definition bind_ {T S : Type} (p : parser T) (f : T -> parser S) : parser S :=
  fun (xs : list token) =>
    match p xs with
      | SomeE (t, xs') => f t xs'
      | NoneE err => NoneE err
    end.
Infix ">>=" := bind_ (left associativity, at level 71).
(* OCamlにあわせて、>,<から始まる演算子は、すべて左結合で同一優先順位とする。
実際は、右結合のほうが使いやすいとおもう。 *)

(* bind2 : parser T -> parser S -> parser S *)
Definition bind2_ {T S : Type} (p1 : parser T) (p2 : parser S) : parser S :=
  p1 >>= fun _ => p2.
Infix ">>>" := bind2_ (left associativity, at level 71).

(* bind1 : parser T -> parser S -> parser T *)
Definition bind1_ {T S : Type} (p1 : parser T) (p2 : parser S) : parser T :=
  p1 >>= fun x => p2 >>> ret x.
Infix "<<<" := bind1_ (left associativity, at level 71).

(* or : parser T -> parser T -> parser T *)
Definition or_ {T : Type} (p1 p2 : parser T) : parser T :=
  fun (xs : list token) =>
    match p1 xs with
      | SomeE (t, xs') => SomeE (t, xs')
      | NoneE err1 =>
        match p2 xs with
          | SomeE (t, xs') => SomeE (t, xs')
          | NoneE err2 => NoneE (err1 ++ err2) (* エラー文字列の連結 *)
        end
    end.
Infix "<|>" := or_ (left associativity, at level 71).

(* and : parser T -> parser S -> parser (T * S) *)
Definition and_ {T S : Type} (p1 : parser T) (p2 : parser S) : parser (T * S) :=
  p1
    >>= fun x => p2
                   >>= fun y => ret (x, y).
Infix ">*<" := and_ (left associativity, at level 71).

(* many : parser T -> parser (list T) *)
Fixpoint many {T : Type} (steps : nat) (p : parser T) : parser (list T) :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      (p                                    (* ここの括弧は必要！ *)
         >>= fun x => many steps' p
                           >>= fun xs => ret (x :: xs))
      <|>
      ret [::]
  end.

(* A parser which expects a given token, followed by p *)
(* pの前のトークン（補足例："IF"、"("、"*"など）を引数とするパーサ *)
Definition firstExpect {T} (t : token) (p : parser T) : parser T :=
  fun xs =>
    match xs with
      | x::xs' =>
        if string_dec x t then
          p xs'
        else
          NoneE ("expected '" ++ t ++ "'.")
      | [::] =>
        NoneE ("expected '" ++ t ++ "'.")
    end.

(* A parser which expects a particular token *)
(* 特定のトークンを引数とするパーサ *)
(* T = unit
   補足：parse reserved word とおもってよい。 *)
Definition expect (t : token) : parser unit :=
  firstExpect t (fun xs => SomeE (tt, xs)).
Check tt.                                   (* unit *)
Check (expect ")"%string).                  (* parser unit *)
Check (expect ")"%string [::]).             (* optionE (unit * list token) *)
Check (expect "true"%string).               (* parser unit *)

(** 抽象構文 *)
Inductive id : Type :=
  Id : nat -> id.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

(*
Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).
*)

(** Impの再帰下降パーサ を「モナディック パーサー コンビネータ」で書き換えた。 *)

(* Identifiers *)
(* 識別子 *)
Definition parseIdentifier symtable (xs : list token) : optionE (id * list token) :=
    match xs with
      | [::] =>
        NoneE "Expected identifier"
      | x::xs' =>
        if forallb isLowerAlpha (list_of_string x) then
          SomeE (Id (symtable x), xs')
        else
          NoneE ("Illegal identifier:'" ++ x ++ "'")
    end.
(* Numbers *)
(* 数値 *)
Definition parseNumber (xs : list token) : optionE (nat * list token) :=
    match xs with
      | [::] =>
        NoneE "Expected number"
      | x::xs' =>
        if forallb isDigit (list_of_string x) then
          SomeE (foldl (fun n d => 10 * n + (nat_of_ascii d - nat_of_ascii "0"%char))
                       0
                       (list_of_string x),
                 xs')
        else
          NoneE "Expected number"
    end.

(* parser (seq T) を parser T に変換するユーティリティ *)
Definition foldlParser {T : Type}
           (f : T -> T -> T) (e : T) (p : parser (seq T)) : parser T :=
  fun (xs : list token) =>
    match p xs with
      | SomeE (es, rest') =>
        SomeE (foldl f e es, rest')         (* T * token list *)
      | NoneE err =>
        NoneE err
    end.

(* Parse arithmetic expressions *)
(* 算術式の構文解析 *)
Fixpoint parsePrimaryExp (steps : nat) symtable : parser aexp :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      (parseIdentifier symtable >>= fun x => ret (AId x))
                      <|>
                      (parseNumber >>= fun x => ret (ANum x))
                      <|>
                      (expect "("%string
                              >>>
                              parseSumExp steps' symtable
                              <<<
                              expect ")"%string)
  end
with parseProductExp (steps : nat) symtable : parser aexp :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      parsePrimaryExp steps' symtable
                      >>=
                      fun (x : aexp) =>
                        foldlParser AMult
                                    x
                                    (many steps' (expect "*"%string
                                                         >>>
                                                         parsePrimaryExp steps' symtable))
  end
with parseSumExp (steps : nat) symtable : parser aexp :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      parseProductExp steps' symtable
                      >>=
                      fun (x : aexp) =>
                        foldlParser APlus
                                    x
                                    (many steps' (expect "+"%string
                                                         >>>
                                                         parseProductExp steps' symtable))
  (* AMinus ("-") は、未実装。foldlParser で挿入するコンストラクタをどう選べばよいのか。 *)
  end.

Definition parseAExp := parseSumExp.

Fixpoint parseAtomicExp (steps : nat) symtable : parser bexp :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      (expect "true"%string
              >>>
              ret BTrue)
        <|>
        (expect "false"%string
                >>>
                ret BFalse)
        <|>
        (expect "not"%string
                >>>
                parseAtomicExp steps' symtable)
        <|>
        (expect "("%string
                >>>
                parseConjunctionExp steps' symtable
                <<<
                expect ")"%string)
        <|>
        (parseProductExp steps' symtable
                         >>=
                         fun x =>
                           (expect "=="%string
                                   >>>
                                   (parseAExp steps' symtable)
                                   >>=
                                   fun x' => ret (BEq x x'))
                             <|>
                             (expect "<="%string
                                     >>>
                                     (parseAExp steps' symtable)
                                     >>=
                                     fun x' => ret (BLe x x')))
  end
with parseConjunctionExp (steps : nat) symtable : parser bexp :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      parseAtomicExp steps' symtable
                     >>=
                     fun (x : bexp) =>
                       foldlParser BAnd
                                    x
                                    (many steps' (expect "&&"%string
                                                         >>>
                                                         parseAtomicExp steps' symtable))
  end.

Definition parseBExp := parseConjunctionExp.

Fixpoint parseSimpleCommand (steps : nat) symtable : parser com :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      (expect "SKIP"%string
              >>>
              ret CSkip)
        <|>
        (expect "IF"%string
                >>>
                (parseBExp steps' symtable
                           >>=
                           fun x =>
                             expect "THEN"%string
                                    >>>
                                    (parseSequencedCommand steps' symtable
                                                           >>=
                                                        fun x' =>
                                                          expect "ELSE"%string
                                                                 >>>
                                                                 (parseSequencedCommand steps' symtable
                                                                                >>=
                                                                                fun x'' =>
                                                                                expect "END"%string
                                                                                >>>
                                                                                ret (CIf x x' x'')))))
        <|>
        (expect "WHILE"%string
                >>>
                (parseBExp steps' symtable
                           >>=
                           fun x =>
                             expect "DO"%string
                                    >>>
                                    (parseSequencedCommand steps' symtable
                                                        >>=
                                                        fun x' =>
                                                          expect "END"%string
                                                                 >>>
                                                                 ret (CWhile x x'))))
        <|>
        (parseIdentifier symtable
                         >>=
                         fun x =>
                           expect ":="%string
                                  >>>
                                  (parseAExp steps' symtable
                                             >>=
                                             fun x' => ret (CAss x x')))
  end
with parseSequencedCommand (steps : nat) symtable : parser com :=
  match steps with
    | 0 =>
      fun _ => NoneE "Too_many_recursive_calls"
    | S steps' =>
      (parseSimpleCommand steps' symtable
                          >>=
                          fun x =>
                            (expect ";"%string
                                    >>>
                                    (parseSequencedCommand steps' symtable
                                                           >>=
                                                           fun x' => ret (CSeq x x')))
                              <|>
                              ret x)

  end.

Definition parse (str : string) : optionE (com * list token) :=
  let tokens := tokenize str in             (* (1) *)
    parseSequencedCommand 20                (* (3) *)
    (build_symtable tokens 0)               (* (2) *)
    tokens.

(* Sample *)
Eval compute in build_symtable [:: "a"; "+"; "b"]%string.
Eval compute in build_symtable [:: "a"; "+"; "b"]%string 0 "a"%string. (* 0 *)
Eval compute in build_symtable [:: "a"; "+"; "b"]%string 0 "b"%string. (* 1 *)

Eval compute in parseNumber [:: "123"]%string.
Eval compute in parseIdentifier (build_symtable [:: "a"]%string 0)
                                [:: "a"]%string.
Eval compute in parsePrimaryExp 1000 (build_symtable [::] 0)
                                [:: "123"]%string.
Eval compute in parsePrimaryExp 1000 (build_symtable [::] 0)
                                [:: "("; "123"; ")" ]%string.
Eval compute in parseProductExp 1000 (build_symtable [::] 0)
                                [:: "123" ]%string.
Eval compute in parseProductExp 1000 (build_symtable [::] 0) (* 左結合になっている。 *)
                                [:: "123"; "*"; "456"; "*"; "789"]%string.
Eval compute in parseSumExp 1000 (build_symtable [::] 0) (* 左結合になっている。 *)
                            [:: "123"; "+"; "456"; "+"; "789"]%string.
Eval compute in parseAExp 1000 (build_symtable [::] 0)
                          [:: "("; "123"; "+"; "345"; ")"; "*"; "679" ]%string.
Eval compute in parseAExp 1000 (build_symtable [::] 0)
                          [:: "123"; "+"; "345"; "*"; "679" ]%string.

Eval compute in parseBExp 10 (build_symtable [::] 0)
                          [:: "123"; "=="; "345" ]%string.
Eval compute in parseBExp 10 (build_symtable [::] 0)
                          [:: "123"; "=="; "345"; "&&"; "321"; "=="; "543"]%string.
Eval compute in parseBExp 10 (build_symtable [::] 0) (* 左結合になっている。 *)
                          [:: "1"; "=="; "2"; "&&"; "3"; "<="; "4"; "&&";
                           "5"; "<="; "6"; "&&"; "7"; "=="; "8"]%string.

Eval compute in parseSimpleCommand 10 (build_symtable [::] 0)
                                   [:: "IF"; "1"; "=="; "1"; "THEN"; "SKIP"; "ELSE"; "SKIP"; "END"]%string.
Eval compute in parseSimpleCommand 10 (build_symtable [::] 0)
                                   [:: "WHILE"; "1"; "=="; "1"; "DO"; "SKIP"; "END"]%string.
Eval compute in parseSimpleCommand 10 (build_symtable [:: "a"; "="; "1"]%string 0)
                                   [:: "a"; ":="; "1"]%string.
Eval compute in parseSequencedCommand 10 (build_symtable [::] 0) (* 右結合になっている。 *)
                                      [:: "SKIP"; ";"; "SKIP"; ";"; "SKIP"]%string.

Eval compute in parse "
    IF x == y + 1 + 2 + y * 6 + 3 THEN
      x := x * 1;
      y := 0
    ELSE
      SKIP
    END  ".

Eval compute in parse "
    SKIP;
    z:=x*y*(x*x);
    WHILE x==x DO
      IF z <= z*z && not x == 2 THEN
        x := z;
        y := z
      ELSE
        SKIP
      END;
      SKIP
    END;
    x:=z  ".

(* END *)


From Undecidability Require Import TM.Util.TM_facts TM.Basic.Mono TM.Combinators.Combinators TM.Compound.Multi.
Require Import List.
From Undecidability Require Import TMTac.
From Coq Require Import List.

Set Default Goal Selector "!".

(* Useful for running time stuff *)
Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

(* The correctness and definition of [WriteString] is non-standard, because it is defined (and verified) by recursion (or induction). *)
Section Write_String.

  Variable sig : finType.
  Variable D : move.

  Fixpoint WriteString (l : list sig) : pTM sig unit 1 :=
    match l with
    | [] => Nop
    | [x] => Write x
    | x :: xs => WriteMove x D;; WriteString xs
    end.

  Fixpoint WriteString_Fun (sig' : Type) (t : tape sig') (str : list sig') :=
    match str with
    | nil => t
    | [x] => tape_write t (Some x)
    | x :: str' => WriteString_Fun (doAct t (Some x, D)) str'
    end.

  Lemma WriteString_Fun_eq (sig' : Type) (t : tape sig') (str : list sig') :
    WriteString_Fun t str =
    match str with
    | nil => t
    | [x] => tape_write t (Some x)
    | x :: str' => WriteString_Fun (doAct t (Some x, D)) str'
    end.
  Proof. destruct str; auto. Qed.

  Lemma Write_String_nil (sig' : Type) (t : tape sig') :
    WriteString_Fun t nil = t.
  Proof. destruct t; cbn; auto. Qed.

  Fixpoint WriteString_sem_fix (str : list sig) : pRel sig unit 1 :=
    match str with
    | nil => Nop_Rel
    | [x] => Write_Rel x
    | x :: str' =>
      WriteMove_Rel x D |_tt ∘ WriteString_sem_fix str'
    end.

  Definition WriteString_steps l :=
    2 * l - 1.

  Lemma WriteString_fix_Sem (str : list sig) :
    WriteString str ⊨c(WriteString_steps (length str)) (WriteString_sem_fix str).
  Proof.
    induction str as [ | s [ | s' str'] IH ].
    - apply Nop_Sem.
    - apply Write_Sem.
    - change (WriteString (s :: s' :: str')) with (WriteMove s D;; WriteString (s' :: str')).
      eapply RealiseIn_monotone.
      { apply Seq_RealiseIn.
        - apply WriteMove_Sem.
        - apply IH. }
      { unfold WriteString_steps. cbn. lia. }
      { intros t1 t3 H. destruct H as (()&t2&H1&H2).
        change (WriteString_sem_fix (s :: s' :: str')) with (WriteMove_Rel s D |_tt ∘ WriteString_sem_fix (s' :: str')).
        exists t2. split; auto.
      }
  Qed.

  Definition WriteString_Rel str : Rel (tapes sig 1) (unit * tapes sig 1) :=
    Mono.Mk_R_p (ignoreParam (fun tin tout => tout = WriteString_Fun tin str)).

  Lemma WriteString_Sem str :
    WriteString str ⊨c(WriteString_steps (length str)) (WriteString_Rel str).
  Proof.
    eapply RealiseIn_monotone.
    { apply WriteString_fix_Sem. }
    { reflexivity. }
    { induction str as [ | s [ | s' str'] IH]; intros tin (yout, tout) H.
      - cbn. now TMSimp.
      - cbn. now TMSimp.
      - change (WriteString_sem_fix (s :: s' :: str')) with ((WriteMove_Rel s D |_tt ∘ WriteString_sem_fix (s' :: str'))) in H.
        destruct H as (tmid&H1&H2). hnf in H1. apply IH in H2.
        (* cbv [WriteString_Rel Mk_R_p ignoreParam].
        change (WriteString_Fun tin[@Fin0] (s :: s' :: str')) with (WriteString_Fun (tape_move_mono tin[@Fin0] (Some s, D)) (s' :: str')). *)
        now TMSimp.
    }
  Qed.

End Write_String.

Arguments WriteString : simpl never.
Arguments WriteString_Rel {sig} (D) (str) x y/.

#[export] Hint Extern 1 (WriteString _ _ ⊨ _) => eapply RealiseIn_Realise; eapply WriteString_Sem : TMdb.
#[export] Hint Extern 1 (WriteString _ _ ⊨c(_) _) => eapply WriteString_Sem : TMdb.
#[export] Hint Extern 1 (projT1 (WriteString _ _) ↓ _) => eapply RealiseIn_TerminatesIn; eapply WriteString_Sem : TMdb.


Require Import Hask.Data.Functor.
Require Import Hask.Control.Applicative.
Require Import Hask.Control.Monad.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

#[export]
Instance Compose_Functor `{Functor F} `{Functor G} : Functor (F \o G) :=
{ fmap := fun A B => @fmap F _ (G A) (G B) \o @fmap G _ A B
}.

#[export]
Instance Compose_Applicative (F : Type -> Type) (G : Type -> Type)
  `{Applicative F} `{Applicative G} : Applicative (F \o G)  :=
{ is_functor := Compose_Functor (F:=F) (G:=G)
; pure := fun A   => @pure F _ (G A) \o @pure G _ A
; ap   := fun A B => ap \o fmap (@ap G _ A B)
}.

#[export]
Instance Compose_Alternative
  `{Alternative F} `{Alternative G} : Alternative (F \o G) :=
{ empty  := fun A => @empty F _ (G A)
; choose := fun A => @choose F _ (G A) (* jww (2016-01-28): correct? *)
}.

#[export]
Instance Compose_Monad `{Monad_Distributes M N}
  : Monad (M \o N) :=
{ is_applicative := Compose_Applicative M N
; join := fun A => join[M] \o fmap[M] (prod M N A)
}.

Require Import FunctionalExtensionality.

Module ComposeMonadLaws.

Import MonadLaws.

Corollary fmap_compose  `{Functor F} `{Functor G} : forall {X Y} (f : X -> Y),
  @fmap F _ (G X) (G Y) (@fmap G _ X Y f) = @fmap (F \o G) _ X Y f.
Proof. reflexivity. Qed.

#[export]
Program Instance Compose_FunctorLaws `{FunctorLaws F} `{FunctorLaws G} :
  FunctorLaws (F \o G).
Obligation 1. (* fmap_id *)
  extensionality x.
  do 2 rewrite fmap_id.
  reflexivity.
Qed.
Obligation 2. (* fmap_comp *)
  extensionality x.
  do 2 rewrite fmap_comp.
  reflexivity.
Qed.

Local Obligation Tactic := intros; simpl; apply_applicative_laws.

#[export]
Program Instance Compose_ApplicativeLaws
  `{ApplicativeLaws F} `{ApplicativeLaws G} : ApplicativeLaws (F \o G).
Obligation 2. (* ap_composition *)
  (* Discharge w *)
  rewrite <- ap_comp; f_equal.
  (* Discharge v *)
  rewrite <- !ap_fmap, <- ap_comp.
  symmetry.
  rewrite <- ap_comp; f_equal.
  (* Discharge u *)
  apply_applicative_laws.
  f_equal.
  extensionality y.
  extensionality x.
  extensionality x0.
  rewrite <- ap_comp, ap_fmap.
  reflexivity.
Qed.

#[export]
Program Instance Compose_MonadLaws
        `{Monad_DistributesLaws M N (H:=Compose_Applicative M N)} :
  MonadLaws (M \o N).
Obligation 1. (* monad_law_1 *)
  intros.
  rewrite <- comp_assoc with (f := join[M]).
  rewrite <- comp_assoc with (f := join[M]).
  rewrite comp_assoc with (f := fmap[M] (prod M N a)).
  rewrite <- join_fmap_fmap.
  rewrite <- comp_assoc.
  rewrite comp_assoc with (f := join[M]).
  rewrite comp_assoc with (f := join[M]).
  rewrite <- join_fmap_join.
  repeat (rewrite <- comp_assoc).
  repeat (rewrite fmap_comp).
  repeat (rewrite comp_assoc).
  rewrite <- prod_fmap_join_fmap_prod.
  reflexivity.
Qed.
Obligation 2. (* monad_law_2 *)
  intros.
  rewrite <- join_fmap_pure.
  repeat (rewrite <- comp_assoc).
  repeat (rewrite fmap_comp).
  repeat f_equal.
  pose proof (@prod_fmap_pure M N _ _ _ _ _ a).
  simpl in H3.
  rewrite H3.
  reflexivity.
Qed.
Obligation 3. (* monad_law_3 *)
  intros.
  rewrite <- prod_pure.
  rewrite <- comp_id_left.
  rewrite <- (@join_pure M _ _ (N a)).
  rewrite <- comp_assoc.
  rewrite <- comp_assoc.
  f_equal.
  rewrite comp_assoc.
  rewrite comp_assoc.
  f_equal.
  rewrite <- fmap_pure.
  reflexivity.
Qed.
Obligation 4. (* monad_law_4 *)
  intros.
  unfold comp at 2.
  rewrite comp_assoc.
  rewrite <- join_fmap_fmap.
  rewrite <- comp_assoc.
  rewrite fmap_comp.
  pose proof (@prod_fmap_fmap M N _ _ _ _ _ a).
  simpl in H3.
  rewrite <- H3.
  rewrite <- fmap_comp.
  reflexivity.
Qed.

End ComposeMonadLaws.


(** * Definition of minimal parse trees *)
Require Import Coq.Strings.String Coq.Lists.List.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.BaseTypes.

Local Coercion is_true : bool >-> Sortclass.

Set Implicit Arguments.
Local Open Scope string_like_scope.

Section cfg.
  Context {Char} {HSLM : StringLikeMin Char} {G : grammar Char}.
  Context {predata : @parser_computational_predataT Char}
          {rdata' : @parser_removal_dataT' _ G predata}.

  Inductive minimal_maybe_empty_productions : nonterminals_listT -> productions Char -> Type :=
  | MinMaybeEmptyHead : forall valid pat pats, minimal_maybe_empty_production valid pat
                                               -> minimal_maybe_empty_productions valid (pat::pats)
  | MinMaybeEmptyTail : forall valid pat pats, minimal_maybe_empty_productions valid pats
                                               -> minimal_maybe_empty_productions valid (pat::pats)
  with minimal_maybe_empty_production : nonterminals_listT -> production Char -> Type :=
  | MinMaybeEmptyProductionNil : forall valid, minimal_maybe_empty_production valid nil
  | MinMaybeEmptyProductionCons : forall valid it its, minimal_maybe_empty_item valid it
                                                       -> minimal_maybe_empty_production valid its
                                                       -> minimal_maybe_empty_production valid (it::its)
  with minimal_maybe_empty_item : nonterminals_listT -> item Char -> Type :=
  | MinMaybeEmptyNonTerminal : forall valid nt, is_valid_nonterminal valid (of_nonterminal nt)
                                                -> minimal_maybe_empty_productions (remove_nonterminal valid (of_nonterminal nt)) (Lookup G nt)
                                                -> minimal_maybe_empty_item valid (NonTerminal nt).

End cfg.


Require Import ssreflect ssrnat ssrbool seq Ssromega OtDef Commons.

Lemma ltnSn n: n < S n. ssromega. Qed.
Lemma list_const: forall X X' (l : list X') (x : X), match l with nil => x | _ :: _ => x end = x.
Proof. intros. destruct l; reflexivity. Qed.

Lemma tstab {cmd} t: forall n k (op1 op2 op1' op2' : list cmd),
transform t op1 op2 n = Some (op2', op1') -> transform t op1 op2 (n + k) = Some (op2', op1').
Proof. elim => [|n IHn] k [|o1 op1] [|o2 op2] op1' op2' //=.
move A1: (transform t _ _ n) => [[x y]|] //; move A2: (transform t _ _ n) => [[x' y']|] // h.
by rewrite (IHn k _ _ _ _ A1) (IHn k _ _ _ _ A2) h. Qed.

(* =============================================== *)

Section OTCorrectness.

Context {X cmd : Type} (ot : OTBase X cmd) (comp : @OTComp X cmd ot).

Lemma sz_nil: sz nil = 0. by rewrite /sz. Qed.
Lemma si_nil: si nil = 0. by rewrite /si. Qed.

Lemma cats_sz (l1 l2 : list cmd): sz (l1 ++ l2) = sz l1 + sz l2.
elim: l1 l2 => [| l ls IHl] l2. by rewrite cat0s sz_nil add0n. rewrite /sz /= in IHl.
by rewrite cat_cons /sz /= ?add0n fadd (fadd (cmdsz l)) IHl addnA. Qed.

Lemma cats_si (l1 l2 : list cmd): si (l1 ++ l2) = si l1 + si l2.
elim: l1 l2 => [| l ls IHl] l2. by rewrite cat0s si_nil add0n. rewrite /si /= in IHl.
by rewrite cat_cons /si /= ?add0n fadd (fadd (cmdsi l)) IHl addnA. Qed.

Lemma execute_app: forall (op1 op2 : list cmd) (m : option X),
(exec_all interp) m (op1 ++ op2) = (exec_all interp) (exec_all interp m op1) op2.
elim => [| x xs IHx] op2 m //. rewrite cat_cons /= IHx //. Qed.

Lemma execute_none op: exec_all interp None op = None.
by elim: op => [|x xs IHx] //=. Qed.

Lemma transform_ind:
forall (op1 op2 : list cmd) n, transform it op1 op2 (S n) =
  match op1, op2 with
    | nil, _ | _, nil => Some (op2, op1)
    | x :: xs, y :: ys =>
       match transform it xs (it y x false) n with
         Some (y'', xs') =>
          match transform it ((it x y true) ++ xs') ys n with
            Some (ys', x'') => Some (y'' ++ ys', x'')
            | _ => None
          end
         | _ => None
       end
  end. done. Qed.

Theorem ot_computability': forall n m (op1 op2 : list cmd),
(sz op1 + sz op2 < n) -> (si op1 + si op2 < m) ->
 (exists n, exists op1', exists op2', transform it op1 op2 n = Some (op2', op1') /\
 (sz op1' + sz op2' <= sz op1 + sz op2) /\
 (si op1' + si op2' <= si op1 + si op2) /\
   (((sz op1' <= sz op1) /\ (sz op2' <= sz op2)) \/
    (si op1' + si op2' < si op1 + si op2))).
 elim => [|n IHn].
 + move => m op1 op2 h. by have: False by ssromega.
 + elim => [|m IHm] // op1 op2.
  case: op1 => [*|x xs].
  + exists 1. exists (@nil cmd). exists op2.
    rewrite ?sz_nil ?si_nil ?add0n /=. split. done.
    split. ssromega. split. ssromega. left. split; ssromega.
  + case: op2 => [*|y ys].
    + exists 1. exists (x :: xs). exists (@nil cmd).
    rewrite ?sz_nil ?si_nil ?add0n ?addn0 /=. split. done.
    split. ssromega. split. ssromega. left. split; ssromega.
      replace (x :: xs) with ([::x] ++ xs); [| by simpl].
      replace (y :: ys) with ([::y] ++ ys); [| by simpl].
    + rewrite ?cats_sz ?cats_si.
      move => h h'. assert (AA := comp_corr x y false). rewrite /computability /= in AA.
      rewrite /cat. assert (E0 := sz_nondg x). assert (E1 := sz_nondg y).
      assert (E0': sz [::x] > 0). by rewrite /sz.
      assert (E1': sz [::y] > 0). by rewrite /sz. clear E0 E1.
      move Heqy': (@it _ _ ot x y true) => x'.
      move Heqx': (@it _ _ ot y x false) => y'.
      rewrite Heqx' Heqy' in AA.
      move: AA => /= [B1[B2[[B0 B0']|B0 {B2}]]];
      [assert (A0: sz xs + sz y' < n) by ssromega;
       move: (IHn (S (si xs + si y')) xs y' A0 (ltnSn _)) |
       assert (A0: sz xs + sz y' < n.+1) by ssromega;
       assert (A0': si xs + si y' < m) by ssromega;
       move: (IHm xs y' A0 A0') ];
      move => [n'1 [xs' [y'' [C1 [C2 [C3 C4]]]]]] {A0};
      [move: C4 => [[C01 C02]|C0];
        [ assert (A0: sz (x' ++ xs') + sz ys < n) by (rewrite cats_sz; ssromega);
          move: (IHn (S (si (x' ++ xs') + si ys)) (x' ++ xs') ys A0 (ltnSn _)) => A1|
          assert (A0: sz (x' ++ xs') + sz ys < S n) by (rewrite cats_sz; ssromega);
          assert (A0': si (x' ++ xs') + si ys < m) by (rewrite cats_si; ssromega);
          move: (IHm (x' ++ xs') ys A0 A0') => A1] |
        assert (A0: sz (x' ++ xs') + sz ys < S n) by (rewrite cats_sz; ssromega);
        clear A0'; assert (A0': si (x' ++ xs') + si ys < m) by (rewrite cats_si; ssromega);
        move: (IHm (x' ++ xs') ys A0 A0') => A1];
       rewrite cats_sz cats_si in A1;
       move: A1 => [n'2 [op1' [ys' [D1 [D2 [D3 D4]]]]]];
       apply (tstab _ _ n'2) in C1; apply (tstab _ _ n'1) in D1; rewrite addnC in D1;
       exists (S (n'1 + n'2));
       rewrite transform_ind Heqy' Heqx' C1 D1;
       exists op1'; exists (y'' ++ ys'); rewrite ?cats_sz ?cats_si;
       (split; [done|split;[ssromega|split;[ssromega|]]]).

       + move: D4 => [[D41 D42]| D4];[left; split |right]; ssromega.
       + right; ssromega.
       + right; ssromega. Qed.

Corollary ot_computability'' op1 op2:
 (exists n, exists op1', exists op2', transform it op1 op2 n = Some (op2', op1') /\
 (sz op1' + sz op2' <= sz op1 + sz op2) /\
 (si op1' + si op2' <= si op1 + si op2) /\
   (((sz op1' <= sz op1) /\ (sz op2' <= sz op2)) \/
    (si op1' + si op2' < si op1 + si op2))).
by apply (ot_computability' (S (sz op1 + sz op2)) (S (si op1 + si op2)) op1 op2 (ltnSn _) (ltnSn _)). Qed.

Corollary ot_computable: forall (op1 op2 : list cmd), exists nSteps op1' op2', transform it op1 op2 nSteps = Some (op2', op1').
move => op1 op2. move: (ot_computability'' op1 op2). move => [n [op1' [op2' [A B]]]]. exists n. exists op1'. exists op2'. done. Qed.

Theorem ot_execution: forall nSteps op1 op2 op1' op2' m (m1 m2 : X), exec_all interp m op1 = Some m1 /\ exec_all interp m op2 = Some m2 ->
transform it op1 op2 nSteps = Some (op2', op1') ->
exec_all interp (Some m1) op2' = exec_all interp (Some m2) op1' /\ exists m3, exec_all interp (Some m1) op2' = Some m3.
elim => [|n IHn] op1 op2 op1' op2' m m1 m2 [h h'] H0 //. rewrite transform_ind in H0.
case: op1 H0 h => [[H0 H1] [h]| x xs H0 h].
  + rewrite -H0 -H1 -h /= h'. by eauto.
  + case: op2 H0 h' h => [[H0 H1] [h']| y ys].
    * rewrite -H0 -H1 -h' /=. eauto.
    * move A0: (it y x false) => y'. move A1: (transform it xs y' n) => [[y'' xs']|] //.
      move A2: (it x y true) => x'.  move A3: (transform it (x' ++ xs') ys n) => [[ys' x'']|] //= [H0 H1].
      rewrite -H0 -H1 execute_app {H0 H1}.
      case: m => [m|]; [|rewrite exec_all_none //]. rewrite /Basics.flip /=.
      move M1: (interp x m) => [t1|]; [|rewrite execute_none]; rewrite //.
      move M2: (interp y m) => [t2|]; [|rewrite execute_none]; move => // h h'.
      move: (it_c1 _ _ true _ _ _ M1 M2). rewrite A0 A2. move => /= [B1 [s1 B2]]. rewrite B1 in B2.

      move: (IHn _ _ _ _ _ _ _ (conj h' B2) A1) => /= [C1 [s2 C2]].
      assert (D1: exec_all interp (Some t2) (x' ++ xs') = Some s2). by rewrite execute_app B1 B2 -C1 C2.
      move: (IHn _ _ _ _ _ _ _ (conj D1 h) A3) => /= [E1 [s3 E2]]. rewrite -E1 C2 E2. by eauto. Qed.

Corollary ot_correctness: forall op1 op2 m (m1 m2 : X),
exec_all interp m op1 = Some m1 /\ exec_all interp m op2 = Some m2 ->
exists nSteps op1' op2', transform it op1 op2 nSteps = Some (op2', op1') /\
exec_all interp (Some m1) op2' = exec_all interp (Some m2) op1' /\ exists m3, exec_all interp (Some m1) op2' = Some m3.
move => op1 op2 m m1 m2 H. move: (ot_computable op1 op2) => [n [op1' [op2' A0]]].
exists n. exists op1'. exists op2'. split. done. by move: (ot_execution _ _ _ _ _ _ _ _ H A0). Qed.

End OTCorrectness.

(* =============================================== *)

Module TransformApp.
Require Import ssreflect ssrbool ssrfun ssrnat.

Corollary tstab1 {cmd} t: forall n (op1 op2 op1' op2' : list cmd),
transform t op1 op2 n = Some (op2', op1') -> transform t op1 op2 (n.+1) = Some (op2', op1').
intros. apply tstab with (k:=1) in H. by rewrite -addn1. Qed.

Lemma tr_through_nil {cmd} t (l : list cmd) n:
transform t l nil n.+1 = Some (nil, l). by rewrite /= list_const. Qed.

Lemma tr_nil {cmd} t (l : list cmd) n:
transform t nil l n.+1 = Some (l, nil). done. Qed.

Lemma part_lemma {cmd} t n: forall (y : cmd) x ys y' x',
transform t x (y :: ys) n = Some (y', x') ->
match transform t x [:: y] n with
  Some (y', x') => match transform t x' ys n with
                     Some (ys', x'') => Some (y' ++ ys', x'')
                     | _ => None
                   end
  | _ => None
end = Some (y', x').
intros. case: n x H => [|n] [|x xs] // H. simpl in H.
case A0: (transform t xs (t y x false) n) H => [[a b]|] // H.
case A1: (transform t (t x y true ++ b) ys n) H => [[c d]|] // [A2 A3].
remember (n.+1) as n1. rewrite {1}Heqn1 /= A0. destruct n. inversion A0.
rewrite tr_through_nil cats0. subst. apply tstab1 in A1. rewrite A1. done. Qed.

Lemma part_lemma2 {cmd} t x (y : cmd) ys y' x' y1' x'' n:
transform t x [:: y] n = Some (y', x') ->
transform t x' ys n = Some (y1', x'') ->
transform t x (y :: ys) n.+1 = Some (y' ++ y1', x'').
case A1: n => [|n1] // H H0.
simpl in H. case: x H => [|x xs] //. simpl.
 + move => [*]. subst. by case: n1 H0 => [|n1] [H0 H1]; rewrite -H0 -H1.
 + case A0: transform => [[y''0 xs']|]//. destruct n1; [inversion A0|].
   rewrite tr_through_nil cats0. move => [A2 A3]. subst.
   remember (n1.+2) as n2. apply tstab1 in A0. rewrite -Heqn2 in A0. simpl. by rewrite A0 H0. Qed.

Lemma vpart1inv {cmd} t: forall y1 (x : list cmd) y2 k,
transform t x y1 k = None -> transform t x (y1 ++ y2) k = None.
elim => [|y1 y1s IHy1]; intros. by case: k x H => [|k] [|a l].
case: k H => [|k] //. rewrite cat_cons. remember (k.+1) as k1. rewrite {1}Heqk1 /=.
destruct x. done. case A1: transform => [[y'' xs']|];[| by subst; rewrite /= A1].
case A2: transform => [[ys' x'']|] // A3 {A3}. subst. simpl. rewrite A1.
by rewrite (IHy1 _ y2 _ A2). Qed.

Theorem vpart1 {cmd} t: forall (y1 : list cmd) n x y2 y' x' y1' x'',
transform t x  y1 n = Some (y', x') ->
transform t x' y2 n = Some (y1', x'') ->
exists k, transform t x (y1 ++ y2) k = Some (y' ++ y1', x'').
elim => [|y y1s IHy] [|n] //; intros.
 + rewrite tr_through_nil in H. inversion H. subst. by exists n.+1.
 + move: (part_lemma _ _ _ _ _ _ _ H).
   case A0: transform => [[y'0 x'0]|]//.
   case A1: transform => [[ys' x''0]|]// [A2 A3].
   rewrite A3 {A3 x''0} in A1. rewrite -A2. rewrite -A2 {A2 y'} in H.
   move: (IHy _ _ _ _ _ _ _ A1 H0) => [k' A2]. apply (tstab _ _ (n.+1)) in A2.
   apply (tstab _ _ k') in A0. rewrite addSn in A0. rewrite addnS addnC in A2.
   exists (n + k').+2. by rewrite cat_cons (part_lemma2 _ _ _ _ _ _ _ _ _ A0 A2) catA. Qed.

Theorem vpart2 {cmd} t: forall (y1 y2 x : list cmd) y' x' n,
transform t x (y1 ++ y2) n = Some (y', x') ->
match transform t x y1 n with
  Some (y1', x') => match transform t x' y2 n with
                     Some (y2', x'') => Some (y1' ++ y2', x'')
                     | _ => None
                   end
  | _ => None
end = Some (y', x').
elim => [|y y1s IHy1] y2 x Y' X' [|n] H //.
 + rewrite /= list_const. case: x y2 H => [|a b] [|c d] //= H. by rewrite H.
 + remember (n.+1) as n1. rewrite cat_cons in H. move: (part_lemma _ _ _ _ _ _ _ H).
   case A0: transform => [[y' x']|] //. case A1: transform => [[ys' x'']|] // [B0 B1].
   rewrite -B1 -B0. rewrite -B1 -B0 {B0 B1 X' Y'} in H.
   move: (IHy1 _ _ _ _ _ A1).
   case A2: transform => [[y1' x'0]|] //.
   case A3: transform => [[y2' x''0]|] // [B2 B3].
   rewrite B3 {B3 x''0 }in A3. rewrite -B2. rewrite -B2 {B2 ys'} in H A1.
   destruct n1; [inversion A0|].
   case A4: transform => [[y1'0 x'1]|];[|by rewrite -cat_cons (vpart1inv t (y::y1s) x y2 (n1.+1) A4) in H].
   move: (part_lemma2 _ _ _ _ _ _ _ _ _ A0 A2) => H0. apply tstab1 in A4. rewrite A4 in H0. inversion H0. subst.
   by rewrite A3 catA. Qed.

Theorem hpart2 {cmd} t n: forall (x1 x2 y y' x': list cmd),
transform t (x1 ++ x2) y n = Some (y', x') ->
exists k,
match transform t x1 y k with
  Some (y', x1') =>
   match transform t x2 y' k with
    Some (y'', x2') => Some (y'', x1' ++ x2')
    | _ => None
   end
  | _ => None
end = Some (y', x').
elim: n => [|n IHn]. done. remember (n.+1) as n1.
case => [|x1 x1s] x2 y Y' X'; intros.
 + rewrite /= in H. exists n1.+1. by rewrite tr_nil (tstab1 _ _ _ _ _ _ H).
 + case: y H => [|y ys] H.
  + rewrite Heqn1 tr_through_nil in H. move: H => [A0 A1].
    exists n1. by rewrite Heqn1 2!tr_through_nil -A0 -A1 -cat_cons.
  + move: H. rewrite {1}Heqn1 /=.
    case A0: transform => [[y'' xs']|] //.
    case A1: transform => [[ys' X'2]|] // [A2 A3].
    move: (IHn _ _ _ _ _ A0) => [k1].
    case A4: transform => [[y' x1s']|] //.
    case A5: transform => [[y''1 x2']|] // [A6 A7].
    rewrite -A7 {A7 xs'} in A1 A0. rewrite A3 {A3 X'2} catA in A1.
    rewrite A6 {A6 y''1} in A5. rewrite -A2 {A2 Y'}.
    move: (IHn _ _ _ _ _ A1) => [k2].
    case A6: transform => [[ys0' x1'']|] //.
    case A7: transform => [[y''0 x2'']|] // [A8 A9].
    rewrite -A9. rewrite -A9 {X' A9} in A1. rewrite A8 {A8 y''0} in A7.
    apply (tstab _ _ k2) in A5. apply (tstab _ _ k1) in A7.
    apply (tstab _ _ k2) in A4. apply (tstab _ _ k1) in A6.
    rewrite addnC in A6 A7.
    move: (vpart1 _ _ _ _ _ _ _ _ _ A5 A7) => [k'' B].
    exists (k1+k2+k'').+1. remember (k1+k2+k'').+1 as k. rewrite {1}Heqk /=.
    apply (tstab _ _ k'') in A4. apply (tstab _ _ k'') in A6.
    apply (tstab _ _ (k1+k2)) in B. rewrite addnC in B.
    by rewrite A4 A6 Heqk (tstab1 _ _ _ _ _ _ B). Qed.

End TransformApp.

(* =============================================== *)

Module Transform2.

Fixpoint transform2 {cmd} (t : cmd -> cmd -> bool -> list cmd) (op1 op2 : list cmd) (nSteps : nat) : option ((list cmd) * (list cmd)) :=
match nSteps with 0 => None | S nSteps' =>
  match op1, op2 with
    | nil, _ | _, nil => Some (op2, op1)
    | x :: xs, y :: ys => let y' := t y x false in let x' := t x y true in
       match transform2 t xs y' nSteps', transform2 t x' ys nSteps' with
         Some (y'', xs'), Some (ys', x'') =>
          match transform2 t xs' ys' nSteps' with
            Some (ys'', xs'') => Some (y'' ++ ys'', x'' ++ xs'')
            | _ => None
          end
         | _, _ => None
       end
  end
end.

Lemma tstab2 {cmd} t: forall n k (op1 op2 op1' op2' : list cmd),
transform2 t op1 op2 n = Some (op2', op1') ->
transform2 t op1 op2 (n + k) = Some (op2', op1').
elim => [|n IHn] k [|o1 op1] [|o2 op2] op1' op2' //=.
case A1: transform2 => [[y'' xs']|] //. case A2: transform2 => [[ys' x'']|] //.
case A3: transform2 => [[ys'' xs'']|] // [B0 B1]. subst.
by rewrite (IHn k _ _ _ _ A1) (IHn k _ _ _ _ A2) (IHn k _ _ _ _ A3). Qed.

Corollary tstab12 {cmd} t: forall n (op1 op2 op1' op2' : list cmd),
transform2 t op1 op2 n = Some (op2', op1') -> transform2 t op1 op2 (n.+1) = Some (op2', op1').
intros. apply tstab2 with (k:=1) in H. by rewrite -addn1. Qed.

Lemma tr2_through_nil {cmd} t (l : list cmd) n:
transform2 t l nil n.+1 = Some (nil, l). by rewrite /= list_const. Qed.

Lemma tr2_nil {cmd} t (l : list cmd) n:
transform2 t nil l n.+1 = Some (l, nil). done. Qed.

End Transform2.