(** FloatIO

   Coqsim_io provides conversion operations between Coq strings
   and the Coq/Compcert data types used in simulation.

   The definitions meant for external use are:

   - nl                                                        A string with a new-line character

   The other definitions are in module FloatIO.

   - Z_to_float (z: Z)                                         Convert Coq integer to float
   - fraction_to_float (m d: Z)                                Convert fraction m*(10^(-d)) to float.
   - nat_power_of_float (x: float) (n: nat)                    x^n
   - Z_to_string_base10 (min_digits: nat) (num : Z) : string   Convert Z to string with min_digits.
   - pad_to_width (width: nat) (s: string)                     Pad string with leading blanks up to width
   - float_to_string (width fdigs: nat) (x: float)             Convert float to string like Ew.(fdigs-1)
   - float_list_to_string (width fdigs: nat) (add_new_line: bool) (al : list float)
                                                               Convert list of floats to string using
                                                               float_to_string width fdigs, and if
                                                               add_new_line is true, append a new line
                                                               at the end.
 *)
From compcert Require Import Floats.
Import Float.
From compcert Require Import IEEE754.Bits.
From compcert Require Import IEEE754_extra.
From compcert Require Import IEEE754.Binary.

From compcert Require Import Integers.
Require Import Coq.Lists.List.
Require Import BinNums.
Require Import Coq.QArith.QArith_base.
Require Import Strings.String.
Require Import Strings.Ascii.
Require Import Coq.ZArith.Znat.
Require Import Recdef.
Require Import Task.monad.

(** Pretty printing
 *)
Open Scope Z.
Open Scope bool_scope.
Open Scope string_scope.
Definition nl := String "010"%char EmptyString.
Close Scope char_scope.

Module FloatIO.
  (* Convert Coq integer to float *)
  Definition Z_to_float (z: Z) :=
    match z with
    | Z0 => Float.zero
    | Zpos x => from_parsed 10 x 0
    | Zneg x => neg (from_parsed 10 x 0)
    end.

  (* Convert a decimal fraction to float.
     First parameter, m, is an integer with all the
     significant digits. The second
     parameter, d, is the number of digits that
     should follow the decimal point.
     The resulting values is

     m * (10^(-d)).

   *)
  Definition fraction_to_float (m d: Z) :=
    match m with
    | Z0 => Float.zero
    | Zpos x => from_parsed 10 x (-d)
    | Zneg x => neg (from_parsed 10 x (-d))
    end.

  Definition floating_one := Z_to_float 1.

  Fixpoint nat_power_of_float (x: float) (n: nat) : float :=
    match n with
    | O => floating_one
    | S p => (mul x (nat_power_of_float x p))
    end.

Module Details.

Definition precision_of_float := 53%Z.
Definition log10of2scaled3 := 301.

Record FloatParts : Set :=
  {
    mantissaSign: bool;
    intPart: string;
    fracPart: string;
    expPart: string
  }.

Fixpoint strToUintHelper (s: string) : option Decimal.uint :=
  match s with
  | EmptyString => Some Decimal.Nil
  | String x x0 =>
    lower <- strToUintHelper x0;
      match x with
      | "0"%char => Some (Decimal.D0 lower)
      | "1"%char => Some (Decimal.D1 lower)
      | "2"%char => Some (Decimal.D2 lower)
      | "3"%char => Some (Decimal.D3 lower)
      | "4"%char => Some (Decimal.D4 lower)
      | "5"%char => Some (Decimal.D5 lower)
      | "6"%char => Some (Decimal.D6 lower)
      | "7"%char => Some (Decimal.D7 lower)
      | "8"%char => Some (Decimal.D8 lower)
      | "9"%char => Some (Decimal.D9 lower)
      | _ => None
      end
    end.

Definition strToUint (s: string) : option Decimal.uint :=
  x <- strToUintHelper s;
  Some (Decimal.unorm x).

(*
Compute strToUint "001234".
Compute strToUint "".
Compute strToUint "0".
Compute strToUint "-3".
*)

Definition strToIntHelper (s: string) : option Decimal.int :=
  match s with
  | EmptyString => Some (Decimal.Pos Decimal.zero)
  | String x x0 =>
    let (sign, digits) :=
        match x with
        | "+"%char => (false, x0)
        | "-"%char => (true, x0)
        | _ => (false, s)
        end in
    uintVal <- strToUint digits;
      Some (if sign then Decimal.Neg uintVal else Decimal.Pos uintVal)
  end.

Definition strToInt (s: string) : option Decimal.int :=
  x <- strToIntHelper s;
  Some (Decimal.norm x).

(*
Compute strToInt "001234".
Compute strToInt "-001234".
Compute strToInt "+001234".
Compute strToInt "".
Compute strToInt "+".
Compute strToInt "-".
Compute strToInt "0".
Compute strToInt "-0".
Compute strToInt "-3".
*)

Definition strToZ (s: string) : option Z :=
  x <- strToInt s;
    Some (Z.of_int x).

(*
Compute strToZ "001234".
Compute strToZ "-001234".
Compute strToZ "+001234".
Compute strToZ "".
Compute strToZ "+".
Compute strToZ "-".
Compute strToZ "0".
Compute strToZ "-0".
Compute strToZ "-3".

Compute String.index 0 "E" "123456E".
*)

Definition splitAtExponent (s: string) : (string * string) :=
  let maybeEpos :=
  match String.index 0 "E" s with
  | Some epos => Some epos
  | None => match String.index 0 "e" s with
           | Some epos => Some epos
           | None => None
           end
  end in
  match maybeEpos with
  | Some epos => (substring 0 epos s, substring (S epos) (String.length s - epos - 1) s)
  | None => (s, EmptyString)
  end.

(*
Compute splitAtExponent "123E456".
Compute splitAtExponent "123E-456".
Compute splitAtExponent "123456".
*)

Definition splitAtPoint (s: string) : (string * string) :=
  match String.index 0 "." s with
  | Some dpos => (substring 0 dpos s, substring (S dpos) (String.length s - dpos - 1) s)
  | None => (s, EmptyString)
  end.

(*
Compute splitAtPoint "123.456".
Compute splitAtPoint "123.-456".
Compute splitAtPoint "123456".
*)

Definition decomposeFloatString  (s: string): (string * string * string) :=
  let (frac, exp) := splitAtExponent s in
  let (intPart, fracPart) := splitAtPoint frac in
  (intPart, fracPart, exp).

(* Compute decomposeFloatString "-123.456e-12". *)

Definition strToFloatHelper (s: string) : option (Z * Z) :=
  let '(intPart, fracPart, exp) := decomposeFloatString s in
  let mantstring := intPart ++ fracPart in
  zmant <- (strToZ mantstring);
    zexp <- (strToZ exp);
    (let adjustedZexp := zexp - Z.of_nat (String.length fracPart) in
     ret (zmant, adjustedZexp)).

(* Compute strToFloatHelper "-123.456e-12". *)

Definition my_nanpl := IEEE754.Bits.default_nan_pl64.
Definition my_nan : float := proj1_sig my_nanpl.

Definition strToFloat (s: string) : float :=
  match strToFloatHelper s with
  | Some (zmant, adjustedZexp) =>
    match zmant with
    | Z0 => Float.zero
    | Zpos x => from_parsed 10 x adjustedZexp
    | Zneg x => neg (from_parsed 10 x adjustedZexp)
    end
  | None => my_nan
  end.

(* Compute strToFloat "-123.456e-12". *)

(* Compute approximate scaling exponent of 10, f, needed to
   get a number with given binary exponent, e, in the range
   10^(d-1) <= value < 10^d

   so we can extract d significant digits.
 *)
Definition scale_exp (d e: Z) :=
  d - 2 - (e + precision_of_float - 1)*log10of2scaled3/1000.

Definition digits (n : Z) : string :=
  match n with
  | 0  => "0" | 6  => "6" | 12 => "c" | 18 => "i" | 24 => "o" | 30 => "u"
  | 1  => "1" | 7  => "7" | 13 => "d" | 19 => "j" | 25 => "p" | 31 => "v"
  | 2  => "2" | 8  => "8" | 14 => "e" | 20 => "k" | 26 => "q" | 32 => "w"
  | 3  => "3" | 9  => "9" | 15 => "f" | 21 => "l" | 27 => "r" | 33 => "x"
  | 4  => "4" | 10 => "a" | 16 => "g" | 22 => "m" | 28 => "s" | 34 => "y"
  | 5  => "5" | 11 => "b" | 17 => "h" | 23 => "n" | 29 => "t" | 35 => "z"
  | _  => "! Error. Max radix is 35 !"
  end.

(* Repeat the given string n times. *)
Fixpoint repeat_string (n: nat) (c: string) : string :=
  match n with
  | O => ""
  | S x => c ++ repeat_string x c
  end.

(* Helper function when computing the digits of an integer base 10. *)
Fixpoint Z_to_string_base10_aux (min_digits fuel: nat) (num : Z) : string :=
  if (num <? 0) then
    "Require non-negative num."
  else
    match fuel with
    | O => "out of fuel"
    | S x => match num with
            | 0 => repeat_string min_digits "0"
            | _ => (Z_to_string_base10_aux (pred min_digits) x (num / 10)) ++ digits (num mod 10)
            end
    end.

Definition Z_to_string_base10 (min_digits: nat) (num : Z) : string :=
  if num <? 0 then
    "-" ++ Z_to_string_base10_aux min_digits 100 (-num)
  else
    if (num =? 0)%Z then
      repeat_string min_digits "0"
    else
      Z_to_string_base10_aux min_digits 100 num.

(* Like Z_to_string_base10 but always print sign *)
Definition Z_to_signed_string_base10 (min_digits: nat) (num : Z) : string :=
  if num >=? 0 then
    "+" ++ Z_to_string_base10 min_digits num
  else Z_to_string_base10 min_digits num.

(* Helper function when computing the digits of an integer base 16. *)
Fixpoint Z_to_string_base16_aux (min_digits fuel: nat) (num : Z) : string :=
  if (num <? 0) then
    "Require non-negative num."
  else
    match fuel with
    | O => "out of fuel"
    | S x => match num with
            | 0 => repeat_string min_digits "0"
            | _ => (Z_to_string_base16_aux (pred min_digits) x (num / 16)) ++ digits (num mod 16)
            end
    end.

Definition Z_to_string_base16 (min_digits: nat) (num : Z) : string :=
  if num <? 0 then
    "-" ++ Z_to_string_base16_aux min_digits 100 (-num)
  else
    if (num =? 0)%Z then
      repeat_string min_digits "0"
    else
      Z_to_string_base16_aux min_digits 100 num.

(* Convert float to Z scaled by 10**fdigs. *)
Definition scaled_float_to_Z (x : float) (fdigs: Z) :=
  match to_long (mul x (from_parsed 10 1 fdigs)) with
  | Some ii => Int64.signed ii
  | None    => 0%Z
  end.

(* Insert decimal point so there are fdigs digits after
   the decimal point.
 *)
Definition insert_decimal(s: string) (fdigs: nat) :=
  let len := length s in
  let front := (len - fdigs)%nat in
  (substring 0 front s) ++ "." ++ (substring front fdigs s).

(* Convert positive finite float to string with given
   number of digits of precision. Other floats return
   empty string as they are covered by the
   floatToStringUnpadded function below.
 *)

Definition float_to_string_unsigned (x: float) (fdigs: nat) :=
  match x with
  | B754_finite false m e _ =>
    let digs_after_dec := pred fdigs in
    let scale := scale_exp (Z.of_nat fdigs) e in
    let scaled := scaled_float_to_Z x scale in
    let b10 := Z_to_string_base10 1 scaled in
    let lb10 := length b10 in
    let scale' :=
        if (lb10 <? fdigs)%nat then
          scale + (Z.of_nat (fdigs - lb10))
        else
          scale
            in
    let b10' :=
        if (lb10 <? fdigs)%nat then
          let scaled' := scaled_float_to_Z x scale' in
          Z_to_string_base10 fdigs scaled'
        else
          b10
            in
    let d10 := insert_decimal b10' digs_after_dec in
    let true_exp := (Z.of_nat fdigs) - scale' - 1 in
    let exp_string := Z_to_signed_string_base10 2 true_exp in
    d10 ++ "e" ++ exp_string
  | _ => ""
  end.

Definition zero_to_string_unpadded (fdigs: nat) :=
  let digs_after_dec := pred fdigs in
  let frac := repeat_string digs_after_dec "0" in
  "0." ++ frac ++ "e+00".

Definition float_to_string_unpadded (x: float) (fdigs: nat) :=
  match x with
  | B754_zero false => "" ++ zero_to_string_unpadded fdigs
  | B754_zero true => "-" ++ zero_to_string_unpadded fdigs
  | B754_infinity false => "inf"
  | B754_infinity true => "-inf"
  | B754_nan false pl _ => "nan" ++ (Z_to_string_base16 14 (Zpos pl))
  | B754_nan true pl _ => "-nan" ++ (Z_to_string_base16 14 (Zpos pl))
  | B754_finite false m e _ => float_to_string_unsigned x fdigs
  | B754_finite true m e _ => "-" ++ float_to_string_unsigned (abs x) fdigs
  end.

Definition pad_to_width (width: nat) (s: string) :=
  let ls := length s in
  let pads := repeat_string (width - ls) " " in
  pads ++ s.

(* Float to string in Ew.d format, with width w and digits d. *)
Definition float_to_string (width fdigs: nat) (x: float)  :=
  pad_to_width width (float_to_string_unpadded x fdigs).

Fixpoint float_list_to_string (width fdigs: nat) (add_new_line: bool) (al : list float) : string :=
  match al with
  | nil => if add_new_line then nl else ""
  | hd :: tl => (float_to_string width fdigs hd) ++ (float_list_to_string width fdigs add_new_line tl)
  end.

End Details.

Module DScopeNotations.

(*+ Float scope notations *)
(* D for double float *)
Bind Scope D_scope with float.
Delimit Scope D_scope with D.

Infix "+" := Float.add : D_scope.
Notation "- x" := (Float.neg x) : D_scope.
Infix "-" := Float.sub : D_scope.
Infix "*" := Float.mul : D_scope.
Infix "/" := Float.div : D_scope.
Infix "?=" := Float.compare (at level 70, no associativity) : D_scope.

Infix "=?" := (Float.cmp Ceq) (at level 70, no associativity) : D_scope.
Infix "<=?" := (Float.cmp Cle) (at level 70, no associativity) : D_scope.
Infix "<?" := (Float.cmp Clt) (at level 70, no associativity) : D_scope.
Infix ">=?" := (Float.cmp Cge) (at level 70, no associativity) : D_scope.
Infix ">?" := (Float.cmp Cgt) (at level 70, no associativity) : D_scope.
Notation "0" := Float.zero : D_scope.
Notation "float_string #D" := (Details.strToFloat float_string) (at level 10) : D_scope.
End DScopeNotations.

Import DScopeNotations.

(* Export items from the details module that the user will want. *)
Definition Z_to_string_base10 := Details.Z_to_string_base10.
Definition pad_to_width := Details.pad_to_width.
Definition float_to_string := Details.float_to_string.
Definition float_list_to_string := Details.float_list_to_string.
Definition strToFloat := FloatIO.Details.strToFloat.
Definition ZofFloat (f: float) :=
  match IEEE754_extra.ZofB 53 1024 f with
  | Some z => z
  | None => 0%Z
  end.

Definition round (f: float) : float :=
  let z := ZofFloat (f + "0.5"#D)%D in
  Z_to_float z.
Search b64_sqrt.
Definition sqrt (arg: float) : float :=
  IEEE754.Bits.b64_sqrt mode_NE arg.

End FloatIO.


Require Import String. Import StringSyntax.

Module Ling.

  Parameter (E : Type).
  Parameter (e : string -> E).
  Parameter (eet : string -> E -> E -> Prop).
  Parameter (et : string -> E -> Prop).
  Parameter (baseAdj : string -> E -> Prop).
  Parameter (Wants : Prop -> E -> Prop).
  Parameter (Knows : Prop -> E -> Prop).
  Parameter (know : E -> Prop -> Prop).
  Parameter (Mother : E -> E).

(* Syntactic categories. *)
Inductive Cat :=
  | DP | S | AP
  | ArrL : Cat -> Cat -> Cat
  | ArrR : Cat -> Cat -> Cat
  | Bound : Cat -> Cat -> Cat
  | GapL : Cat -> Cat -> Cat
  | GapR : Cat -> Cat -> Cat
  | Struct : Cat -> Cat -> Cat
  | Tow : Cat -> Cat -> Cat -> Cat.

(* Mapping of syntactic categories to semantic types. *)
  Fixpoint interp (c : Cat) : Type :=
    match c with
    | DP => E
    | S => Prop
    | AP => E -> Prop
    | ArrL c1 c2 => interp c1 -> interp c2
    | ArrR c1 c2 => interp c2 -> interp c1
    | GapL a b => interp a -> interp b
    | GapR a b => interp b -> interp a
    | Bound x y => interp x -> interp y
    | Struct a b => interp a * (interp a -> interp b)
    | Tow a b c => (interp c -> interp b) -> interp a
                                                    end.

(* This lets me write x : c, where x is a lambda term and c is a category. *)
  Coercion interp : Cat >-> Sortclass.

Notation "x \ y" := (ArrL x y) (at level 40).
Notation "x / y" := (ArrR x y).
Notation "x >> y" := (Bound x y) (at level 40).
Notation "x \\ y" := (GapL x y) (at level 40).
Notation "x // y" := (GapL x y) (at level 40).

Notation "x || y -- z" := (Tow x y z) (at level 30, format "'//' x  ||  y '//' -- '//' z").

Definition john : DP := (e "john").
Definition mary : DP := (e "mary").
Definition ben : DP := (e "ben").
Definition alice : DP := (e "alice").
Definition ari : DP := (e "ari").

(* Lift is like the monadic return. *)
(* c is local type, a is scope type. *)
Definition lift {a : Cat} {c : Cat} (x : c) : a || a -- c :=
  (fun k => k x).

(* In (b || a -- c), c is the local type, a is the scope,
   and b is the scope result. *)

(* Forward Geach type raising.
  NB this uses Bar-Hillel notation for leftward slashes. *)
Definition geach {a : Cat} {c : Cat} (x : c) : (a / (c \ a)) :=
  (fun k => k x).

(* Forward and backward application, with the order of arguments
  following the surface order. *)
Definition appf {a b: Cat} (y : (a / b)) (x : b) : a :=
  (y x).

Definition appb {a b: Cat} (x : b) (y : (b \ a)) : a :=
  (y x).

(* Collapse tower at S. The result is the scope result a. *)
Definition lower {a : Cat} (x : a || S -- S) : a := x id.

(* Apply locally, and compose at the continuation level.
  The order of arguments is the surface order. *)
Definition cleft {a b c x y : Cat}
           (f : a || b -- x)
           (g : b || c -- (x \ y)) : a || c -- y :=
  (fun k => f (fun x => g (fun y => k (y x)))).

Definition cright {a b c x y : Cat}
          (f : a || b -- (x / y))
          (g : b || c -- y) : a || c -- x :=
    (fun k => f (fun x => g (fun y => k (x y)))).

(* Tower application \ composition. The arrow points at the
downstairs argument. *)
Notation "x <| y" := (cleft x y) (at level 41).
Notation "x |> y" := (cright x y) (at level 41).

Definition TV := (DP \ S) / DP.

(* Definition mkTV (s : string) : TV := eet s. *)

Definition mkTV (s : string) : TV := fun (y : E) (x : E) => ((eet s) x y).

(* This puts the subject first in the atomic formula (love john mary) *)
Definition loves : TV := mkTV "love".
Definition kissed : TV := mkTV "kiss".

(*
Eval compute in loves.
  = fun y x : E => eet "love" x y
     : TV
*)

(* Basic application. *)

Notation "x :> y" := (appf x y) (at level 40).
Notation "x <: y" := (appb x y) (at level 40).

(*
Use "shift space" to covert latex to unicode.
\blacktriangleleft \u25c0
\blacktriangleright \u25b7
\triangleright \u25b7
\triangleleft \u25c1
\LeftTriangleBar \u29cf   Hard to read
\Gfr \U0001d50a
Notation "x \u25c2 y"
*)

(*
Eval compute in (john <: (loves :> mary)).
     = eet "love" (e "john") (e "mary")
     : S
*)

(*
Eval compute in ((geach john) :> (loves :> mary)).
     = eet "love" (e "john") (e "mary")
     : S
*)

(* Continuation quantifiers. *)

Definition everyone : S || S -- DP := fun (k : E -> Prop) =>
                                        forall x, et "person" x -> k x.

Definition someone : S || S -- DP := fun k => exists x, et "person" x /\ k x.

Definition to_leave : (DP \ S) := (et "leave" : DP \ S).

Definition wants : ((DP \ S) / S) := (Wants : (DP \ S) / S).

(*
   Syntax of quantifiers with default scopes. The transitive verb is
   lifted to a tower in order to combine with the quantifiers,
   which are towers.

*)

Check (everyone <| (lift loves |> someone)).
Check (someone <| (lift loves |> everyone)).

(* Simple quantifier scope. *)

Eval compute in (lower (everyone <| lift to_leave)).

Check (lift loves) |> someone.
Eval compute in (lift loves) |> someone.

Check everyone <| ((lift loves) |> someone).

(* The scopes come out in linear order. *)

Eval compute in (lower (everyone <| ((lift loves) |> someone))).

(* This one has a variable scope type, which is also the scope
   result type. *)

Check (lift john).

(* This restricts it. *)

Check (lift john) : S || S -- DP.
Eval compute in ((lift john) : S || S -- DP).

(* Section 1.9 in Barker & Shan *)

(* This has matrix scope for the quantifier. *)

Eval compute in (
                 lower (lift mary <| (lift wants |>
                                           (everyone <| lift to_leave)))).
(* "(lift (lower" unscopes the quantifier. *)

Eval compute in (lower (lift mary <| (lift wants |>
                                           (lift (lower (everyone <| lift to_leave)))))).

(* This is equivalent to the above, without tower in the higher part of the derivation. *)

Eval compute in (mary <: (wants :> (lower (everyone <| lift to_leave)))).

(***  Binding  ***)

(* The operator bind applies to a quantifier that takes scope at b,
  and creates one that takes scope at DP >> b).
  The latter is a phrase where a pronoun such as 'he' has just been bound. *)

Definition bind {a b : Cat}
  (x : a || b -- DP) :
  a || (DP >> b) -- DP :=
  fun k => x (fun e => k e e).

(* Local DP that takes scope at S to give DP >> S, which binds
   variable in the position of the pronoun. *)

Definition he : (DP >> S) || S -- DP := fun k => k.

(* Beginning of Chapter 2 in Barker & Shan, listing (28) *)
Eval compute in (lower (he <| lift to_leave)).

Definition mother : (DP \ DP) := (Mother : DP \ DP).

(* Listing 31 *)
(* Everyone loves his mother *)
Eval compute in (lower (
                     bind everyone <|
                     (lift loves |> (he <| lift mother)))).

(* Listing 44, from Chapter 3 *)
(* Someone entered. He left *)
Definition and : (S \ S) / S := fun p2 p1 => p1 /\ p2.

Definition entered : DP \ S := et "enter".
Definition left : DP \ S := et "left".

Eval compute in (lower (
                     (bind someone <| lift entered)
                       <|
                       (lift and |>
                             (he <| lift left))

                )).

(***** Multi-level towers for scope ambiguity ******)
Definition cleft2 {E F H C D G A B : Cat}
           (l : E || F -- (C || D -- A))
           (r : F || H -- (D || G -- (A \ B))) :
           E || H -- (C || G -- B).
  unfold interp in *; simpl in *.
  firstorder.
Defined.

Definition cright2 {E F H C D G A B : Cat}
           (l : E || F -- (C || D -- (A / B)))
           (r : F || H -- (D || G -- (B))) :
           E || H -- (C || G -- A).
  unfold interp in *; simpl in *.
  firstorder.
Defined.

Definition fmap {a b c d : Cat} (f : c -> d) : a || b -- c -> a || b -- d.
  intros x k.
  apply x; intro hc.
  apply k.
  apply f.
  apply hc.
Defined.

(* Listing 52, chapter 4 of Barker & Shan *)

(* Ambiguous notation resolved by types?
Notation "x <|> y" := (cleft2 x y) (at level 41).
Notation "x <|> y" := (cright2 x y) (at level 41). *)

Notation "x ||> y" := (cright2 x y) (at level 41).

Notation "x <|| y" := (cleft2 x y) (at level 41).

Eval compute in (lift someone).

(* Discussion around listing (54) *)
(* lift2 lifts a tower, e.g. quantifier, to a double tower. *)

Definition lift2 {s a b c : Cat} (x : a || b -- c) : a || b -- (s || s -- c) :=
  fmap lift x.

Definition lower2 {a b c : Cat} (x : a || b -- (c || S -- S)) : a || b -- c :=
  fmap lower x.

(* Inverse scope by doing alternative lift / lowers *)
(* Listing (55) *)
Check (lower (lower2 (lift someone <|| ((lift (lift loves)) ||> lift2 everyone)))).
Eval compute in (lower (lower2 (lift someone <|| ((lift (lift loves)) ||> lift2 everyone)))).

End Ling.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                               Lib_Bool.v                                 *)
(****************************************************************************)

Require Export Bool.
Require Export IfProp.
Require Export Zerob.

Lemma bool_dec : forall b : bool, {b = true} + {b = false}.
simple induction b; auto.
Qed.
Hint Immediate bool_dec.

Lemma orb_sym : forall a b : bool, a || b = b || a.
simple induction a; simple induction b; auto.
Qed.
Hint Immediate orb_sym.

Lemma orb_false : forall a b : bool, a || b = false -> a = false /\ b = false.
simple induction a; simple induction b; auto.
Qed.
Hint Immediate orb_false.

Lemma orb_false_l : forall a b : bool, a || b = false -> a = false.
intros; elim (orb_false a b); auto.
Qed.

Lemma orb_false_r : forall a b : bool, a || b = false -> b = false.
intros; elim (orb_false a b); auto.
Qed.

Lemma true_orb_intro :
 forall b1 b2 : bool, b1 || b2 = true -> b1 = true \/ b2 = true.
simple induction b1; auto.
Qed.

Lemma and_sym : forall a b : bool, a && b = b && a.
simple induction a; simple induction b; auto.
Qed.
Hint Immediate and_sym.

Lemma andb_false :
 forall a b : bool,
 a && b = false ->
 a = false /\ b = false \/ a = false /\ b = true \/ a = true /\ b = false.
simple induction a; simple induction b; auto.
Qed.

Lemma andb_true : forall a b : bool, a && b = true -> a = true /\ b = true.
simple induction a; simple induction b; auto.
Qed.

Lemma andb_true_l : forall a b : bool, a && b = true -> a = true.
intros; elim (andb_true a b); auto.
Qed.

Lemma andb_true_r : forall a b : bool, a && b = true -> b = true.
intros; elim (andb_true a b); auto.
Qed.

Lemma andb_negb_true_r : forall a b : bool, a && negb b = true -> b = false.
simple induction b; auto.
elim and_sym; auto.
Qed.

Lemma andb_negb_true_l : forall a b : bool, negb a && b = true -> a = false.
intros a b.
elim and_sym; intros H.
apply andb_negb_true_r with b; auto.
Qed.

Set Implicit Arguments.
Unset Strict Implicit.

Lemma no_true_false : forall b : bool, b = false -> b <> true.
simple induction b; auto with bool.
Qed.
Hint Immediate no_true_false.

Definition if_bool (C : Set) (b : bool) (x y : C) : C :=
  match b return C with
  | true => x
  | false => y
  end.
Notation If := (if_bool _) (only parsing).


Require Import Coq.Lists.List.

Import ListNotations.

Fixpoint repeat_aux {A : Type} (x : A) (n : nat) (l : list A) : list A :=
  match n with
  | O => l
  | S n => repeat_aux x n (x :: l)
  end.

(** Make a list of `n` elements `x`. *)
Definition repeat {A : Type} (x : A) (n : nat) : list A :=
  repeat_aux x n [].

(** Remove the elements `None` of a list. *)
Fixpoint remove_nones {A : Type} (l : list (option A)) : list A :=
  match l with
  | [] => []
  | None :: l => remove_nones l
  | Some x :: l => x :: remove_nones l
  end.

(** Do a map removing the `None` results of `f`. *)
Fixpoint map_filter {A B : Type} (f : A -> option B) (l : list A) : list B :=
  match l with
  | [] => []
  | x :: l =>
    match f x with
    | None => map_filter f l
    | Some y => y :: map_filter f l
    end
  end.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal85.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_2  := ( Succ (Succ Zero)).
Definition lfind_example_3  := ( Succ (Succ (Succ (Succ Zero)))).
Definition lfind_example_4  := ( Succ Zero).
Definition lfind_example_5  := ( Succ (Succ Zero)).
Definition lfind_example_6  := ( Succ (Succ (Succ (Succ (Succ (Succ Zero)))))).
Definition lfind_example_7  := ( Succ (Succ (Succ (Succ (Succ (Succ (Succ Zero))))))).
Definition lfind_example_8  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_9  := ( Succ (Succ (Succ Zero))).
Definition lfind_example_10  := ( Succ (Succ Zero)).
Definition lfind_example_11  := ( Succ Zero).
Definition lfind_example_12  := ( Succ (Succ Zero)).
Definition lfind_example_13  := ( Succ Zero).
Definition lfind_example_14  := ( Succ Zero).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal85_plus_commut_58_plus_succ/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 .


From iris.base_logic Require Import base_logic.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Export hoare.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

(** The proofs from Section 3.1 *)
Section demo.
  Context {M : ucmraT}.
  Notation iProp := (uPred M).

  (* The version in Coq *)
  Lemma and_exist A (P R: Prop) (Ψ: A → Prop) :
    P ∧ (∃ a, Ψ a) ∧ R → ∃ a, P ∧ Ψ a.
  Proof.
    intros [HP [HΨ HR]].
    destruct HΨ as [x HΨ].
    exists x.
    split. assumption. assumption.
  Qed.

  (* The version in IPM *)
  Lemma sep_exist A (P R: iProp) (Ψ: A → iProp) :
    P ∗ (∃ a, Ψ a) ∗ R ⊢ ∃ a, Ψ a ∗ P.
  Proof.
    iIntros "[HP [HΨ HR]]".
    iDestruct "HΨ" as (x) "HΨ".
    iExists x.
    iSplitL "HΨ". iAssumption. iAssumption.
  Qed.

  (* The short version in IPM, as in the paper *)
  Lemma sep_exist_short A (P R: iProp) (Ψ: A → iProp) :
    P ∗ (∃ a, Ψ a) ∗ R ⊢ ∃ a, Ψ a ∗ P.
  Proof. iIntros "[HP [HΨ HR]]". iFrame "HP". iAssumption. Qed.

  (* An even shorter version in IPM, using the frame introduction pattern `$` *)
  Lemma sep_exist_shorter A (P R: iProp) (Ψ: A → iProp) :
    P ∗ (∃ a, Ψ a) ∗ R ⊢ ∃ a, Ψ a ∗ P.
  Proof. by iIntros "[$ [??]]". Qed.
End demo.

(** The proofs from Section 3.2 *)
(** In the Iris development we often write specifications directly using weakest
preconditions, in sort of `CPS` style, so that they can be applied easier when
proving client code. A version of [list_reverse] in that style can be found in
the file [theories/tests/list_reverse.v]. *)
Section list_reverse.
  Context `{!heapG Σ, !probG Σ}.
  Notation iProp := (iProp Σ).
  Implicit Types l : loc.

  Fixpoint is_list (hd : val) (xs : list val) : iProp :=
    match xs with
    | [] => ⌜hd = NONEV⌝
    | x :: xs => ∃ l hd', ⌜hd = SOMEV #l⌝ ∗ l ↦ (x,hd') ∗ is_list hd' xs
    end%I.

  Definition rev : val :=
    rec: "rev" "hd" "acc" :=
      match: "hd" with
        NONE => "acc"
      | SOME "l" =>
         let: "tmp1" := Fst !"l" in
         let: "tmp2" := Snd !"l" in
         "l" <- ("tmp1", "acc");;
         "rev" "tmp2" "hd"
      end.

  Lemma rev_acc_ht hd acc xs ys :
    {{ is_list hd xs ∗ is_list acc ys }} rev hd acc {{ w, is_list w (reverse xs ++ ys) }}.
  Proof.
    iIntros "!# [Hxs Hys]".
    iLöb as "IH" forall (hd acc xs ys). wp_rec; wp_let.
    destruct xs as [|x xs]; iSimplifyEq.
    - (* nil *) by wp_match.
    - (* cons *) iDestruct "Hxs" as (l hd') "(% & Hx & Hxs)"; iSimplifyEq.
      wp_match. wp_load. wp_proj. wp_let. wp_load. wp_proj. wp_let. wp_store.
      rewrite reverse_cons -assoc.
      iApply ("IH" $! hd' (InjRV #l) xs (x :: ys) with "Hxs [Hx Hys]").
      iExists l, acc; by iFrame.
  Qed.

  Lemma rev_ht hd xs :
    {{ is_list hd xs }} rev hd NONE {{ w, is_list w (reverse xs) }}.
  Proof.
    iIntros "!# Hxs". rewrite -(right_id_L [] (++) (reverse xs)).
    iApply (rev_acc_ht hd NONEV with "[Hxs]"); simpl; by iFrame.
  Qed.
End list_reverse.

(** The proofs from Section 5 *)
(** This part contains a formalization of the monotone counter, but with an
explicit contruction of the monoid, as we have also done in the proof mode
paper. This should simplify explaining and understanding what is happening.
A version that uses the authoritative monoid and natural number monoid
under max can be found in [theories/heap_lang/lib/counter.v]. *)

(** The invariant rule in the paper is in fact derived from mask changing
update modalities (which we did not cover in the paper). Normally we use these
mask changing update modalities directly in our proofs, but in this file we use
the first prove the rule as a lemma, and then use that. *)
Lemma wp_inv_open `{irisG Λ Σ} N E P e Φ :
  nclose N ⊆ E → Atomic WeaklyAtomic e →
  inv N P ∗ (▷ P -∗ WP e @ E ∖ ↑N {{ v, ▷ P ∗ Φ v }}) ⊢ WP e @ E {{ Φ }}.
Proof.
  iIntros (??) "[#Hinv Hwp]".
  iMod (inv_open E N P with "Hinv") as "[HP Hclose]"=>//.
  iApply wp_wand_r; iSplitL "HP Hwp"; [by iApply "Hwp"|].
  iIntros (v) "[HP $]". by iApply "Hclose".
Qed.

Definition newcounter : val := λ: <>, ref #0.
Definition incr : val :=
  rec: "incr" "l" :=
    let: "n" := !"l" in
    if: CAS "l" "n" (#1 + "n") then #() else "incr" "l".
Definition read : val := λ: "l", !"l".

(** The CMRA we need. *)
Inductive M := Auth : nat → M | Frag : nat → M | Bot.

Section M.
  Arguments cmra_op _ !_ !_/.
  Arguments op _ _ !_ !_/.
  Arguments core _ _ !_/.

  Canonical Structure M_C : ofeT := leibnizC M.

  Instance M_valid : Valid M := λ x, x ≠ Bot.
  Instance M_op : Op M := λ x y,
    match x, y with
    | Auth n, Frag j | Frag j, Auth n => if decide (j ≤ n)%nat then Auth n else Bot
    | Frag i, Frag j => Frag (max i j)
    | _, _ => Bot
    end.
  Instance M_pcore : PCore M := λ x,
    Some match x with Auth j | Frag j => Frag j | _ => Bot end.
  Instance M_unit : Unit M := Frag 0.

  Definition M_ra_mixin : RAMixin M.
  Proof.
    apply ra_total_mixin; try solve_proper || eauto.
    - intros [n1|i1|] [n2|i2|] [n3|i3|];
        repeat (simpl; case_decide); f_equal/=; lia.
    - intros [n1|i1|] [n2|i2|]; repeat (simpl; case_decide); f_equal/=; lia.
    - intros [n|i|]; repeat (simpl; case_decide); f_equal/=; lia.
    - by intros [n|i|].
    - intros [n1|i1|] y [[n2|i2|] ?]; exists (core y); simplify_eq/=;
        repeat (simpl; case_decide); f_equal/=; lia.
    - intros [n1|i1|] [n2|i2|]; simpl; by try case_decide.
  Qed.
  Canonical Structure M_R : cmraT := discreteR M M_ra_mixin.

  Global Instance M_discrete : CmraDiscrete M_R.
  Proof. apply discrete_cmra_discrete. Qed.

  Definition M_ucmra_mixin : UcmraMixin M.
  Proof.
    split; try (done || apply _).
    intros [?|?|]; simpl; try case_decide; f_equal/=; lia.
  Qed.
  Canonical Structure M_UR : ucmraT := UcmraT M M_ucmra_mixin.

  Global Instance frag_core_id n : CoreId (Frag n).
  Proof. by constructor. Qed.
  Lemma auth_frag_valid j n : ✓ (Auth n ⋅ Frag j) → (j ≤ n)%nat.
  Proof. simpl. case_decide. done. by intros []. Qed.
  Lemma auth_frag_op (j n : nat) : (j ≤ n)%nat → Auth n = Auth n ⋅ Frag j.
  Proof. intros. by rewrite /= decide_True. Qed.

  Lemma M_update n : Auth n ~~> Auth (S n).
  Proof.
    apply cmra_discrete_update=>-[m|j|] /= ?; repeat case_decide; done || lia.
  Qed.
End M.

Class counterG Σ := CounterG { counter_tokG :> inG Σ M_UR }.
Definition counterΣ : gFunctors := #[GFunctor (constRF M_UR)].
Instance subG_counterΣ {Σ} : subG counterΣ Σ → counterG Σ.
Proof. intros [?%subG_inG _]%subG_inv. split; apply _. Qed.

Section counter_proof.
  Context `{!heapG Σ, !probG Σ, !counterG Σ}.
  Implicit Types l : loc.

  Definition I (γ : gname) (l : loc) : iProp Σ :=
    (∃ c : nat, l ↦ #c ∗ own γ (Auth c))%I.

  Definition C (l : loc) (n : nat) : iProp Σ :=
    (∃ N γ, inv N (I γ l) ∧ own γ (Frag n))%I.

  (** The main proofs. *)
  Global Instance C_persistent l n : Persistent (C l n).
  Proof. apply _. Qed.

  Lemma newcounter_spec :
    {{ True }} newcounter #() {{ v, ∃ l, ⌜v = #l⌝ ∧ C l 0 }}.
  Proof.
    iIntros "!# _ /=". rewrite -wp_fupd /newcounter /=. wp_seq. wp_alloc l as "Hl".
    iMod (own_alloc (Auth 0)) as (γ) "Hγ"; first done.
    rewrite (auth_frag_op 0 0) //; iDestruct "Hγ" as "[Hγ Hγf]".
    set (N:= nroot .@ "counter").
    iMod (inv_alloc N _ (I γ l) with "[Hl Hγ]") as "#?".
    { iIntros "!>". iExists 0%nat. by iFrame. }
    iModIntro. rewrite /C; eauto 10.
  Qed.

  Lemma incr_spec l n :
    {{ C l n }} incr #l {{ v, ⌜v = #()⌝ ∧ C l (S n) }}.
  Proof.
    iIntros "!# Hl /=". iLöb as "IH". wp_rec.
    iDestruct "Hl" as (N γ) "[#Hinv Hγf]".
    wp_bind (! _)%E. iApply wp_inv_open; last iFrame "Hinv"; auto.
    iDestruct 1 as (c) "[Hl Hγ]".
    wp_load. iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    wp_let. wp_op.
    wp_bind (CAS _ _ _). iApply wp_inv_open; last iFrame "Hinv"; auto.
    iDestruct 1 as (c') ">[Hl Hγ]".
    destruct (decide (c' = c)) as [->|].
    - iCombine "Hγ" "Hγf" as "Hγ".
      iDestruct (own_valid with "Hγ") as %?%auth_frag_valid; rewrite -auth_frag_op //.
      iMod (own_update with "Hγ") as "Hγ"; first apply M_update.
      rewrite (auth_frag_op (S n) (S c)); last lia; iDestruct "Hγ" as "[Hγ Hγf]".
      wp_cas_suc. iSplitL "Hl Hγ".
      { iNext. iExists (S c). rewrite Nat2Z.inj_succ Z.add_1_l. by iFrame. }
      wp_if. rewrite {3}/C; eauto 10.
    - wp_cas_fail; first (intros [=]; abstract omega).
      iSplitL "Hl Hγ"; [iNext; iExists c'; by iFrame|].
      wp_if. iApply ("IH" with "[Hγf]"). rewrite {3}/C; eauto 10.
  Qed.

  Lemma read_spec l n :
    {{ C l n }} read #l {{ v, ∃ m : nat, ⌜v = #m ∧ n ≤ m⌝ ∧ C l m }}.
  Proof.
    iIntros "!# Hl /=". iDestruct "Hl" as (N γ) "[#Hinv Hγf]".
    rewrite /read /=. wp_let. iApply wp_inv_open; last iFrame "Hinv"; auto.
    iDestruct 1 as (c) "[Hl Hγ]". wp_load.
    iDestruct (own_valid γ (Frag n ⋅ Auth c) with "[-]") as % ?%auth_frag_valid.
    { iApply own_op. by iFrame. }
    rewrite (auth_frag_op c c); last lia; iDestruct "Hγ" as "[Hγ Hγf']".
    iSplitL "Hl Hγ"; [iNext; iExists c; by iFrame|].
    rewrite /C; eauto 10 with omega.
  Qed.
End counter_proof.


(* When these things get proven, they ought to move to [containers] *)

From Coq Require Import ssreflect ssrfun ssrbool.

Require Import Coq.Logic.ProofIrrelevance.

Require Import GHC.Base.

Require Import Proofs.Prelude.
Require Import MapProofs.ContainerFacts.
Require IntMap.

Ltac destruct_IntMap :=
  repeat match goal with
  | [x : IntMap.IntMap _ |- _ ] =>
    destruct x; try solve [simpl; eassumption]
  end.

Lemma member_eq : forall A k k' (i : IntMap.IntMap A),
    k == k' ->
    IntMap.member k i = IntMap.member k' i.
Proof.
  intros. cbn in H. apply N.eqb_eq in H; subst. reflexivity.
Qed.

Lemma lookup_insert : forall A key (val:A) i,
    IntMap.lookup key (IntMap.insert key val i) = Some val.
Proof.
  intros. eapply lookup_insert'. destruct_IntMap.
Qed.

Lemma lookup_singleton_key : forall {A} x y (a b : A),
    IntMap.lookup x (IntMap.singleton y a) = Some b -> x == y.
Proof.
  unfold IntMap.singleton, IntMap.lookup. simpl. intros.
  destruct (compare x y) eqn:Hc;
    rewrite Hc in H; inversion H.
  apply Bounds.compare_Eq => //.
Qed.

Lemma lookup_singleton_val : forall {A} x y (a b : A),
    IntMap.lookup x (IntMap.singleton y a) = Some b -> a = b.
Proof.
  unfold IntMap.singleton, IntMap.lookup. simpl. intros.
  destruct (compare x y) eqn:Hc;
    rewrite Hc in H; inversion H.
  reflexivity.
Qed.

Lemma lookup_insert_neq :
  forall b key1 key2 (val:b) m,
    key1 <> key2 ->
    IntMap.lookup key1 (IntMap.insert key2 val m) = IntMap.lookup key1 m.
Proof.
  intros. apply lookup_insert_neq'; destruct_IntMap.
  apply /Eq_eq; assumption.
Qed.

Lemma member_insert : forall A k k' v (i : IntMap.IntMap A),
IntMap.member k (IntMap.insert k' v i) =
  (k == k') || IntMap.member k i.
Proof.
  intros. apply member_insert'; destruct_IntMap.
Qed.

Lemma delete_eq : forall key b (i : IntMap.IntMap b),
    IntMap.lookup key (IntMap.delete key i) = None.
Proof.
  intros. eapply delete_eq; destruct_IntMap.
Qed.

Lemma delete_neq : forall key1 key2 b (i : IntMap.IntMap b),
    key1 <> key2 ->
    IntMap.lookup key1 (IntMap.delete key2 i) = IntMap.lookup key1 i.
Proof.
  intros. eapply delete_neq; destruct_IntMap.
  apply /Eq_eq =>//.
Qed.

Lemma member_delete_neq : forall k1 k2 b (i: IntMap.IntMap b), k1 <> k2 ->
  IntMap.member k2 (IntMap.delete k1 i) =
  IntMap.member k2 i.
Proof.
  intros. eapply member_delete_neq; destruct_IntMap.
  apply /Eq_eq =>//.
Qed.

Lemma non_member_lookup :
   forall (A : Type)
     (key : Internal.Key)
     (i : IntMap.IntMap A),
   (IntMap.member key i = false) <-> (IntMap.lookup key i = None).
Proof.
  intros. eapply non_member_lookup.
  destruct_IntMap.
Qed.

Lemma lookup_eq : forall A k k' (i : IntMap.IntMap A),
    k == k'->
    IntMap.lookup k i = IntMap.lookup k' i.
Proof.
  intros. eapply lookup_eq. assumption.
Qed.

Lemma member_lookup :
   forall (A : Type)
     (key : Internal.Key)
     (i : IntMap.IntMap A),
   (is_true (IntMap.member key i)) <-> (exists val, IntMap.lookup key i = Some val).
Proof.
  intros. eapply member_lookup. destruct_IntMap.
Qed.

Lemma null_empty : forall A,
    (@IntMap.null A IntMap.empty).
Proof.
  intros. cbv. reflexivity.
Qed.

(* ------------------------------------------------------- *)

Lemma member_union :
   forall (A : Type)
     (key : Internal.Key)
     (i i0 : IntMap.IntMap A),
   (IntMap.member key (IntMap.union i i0)) =
   (IntMap.member key i0 || IntMap.member key i).
Proof.
  intros. eapply member_union; destruct_IntMap.
Qed.

(*
Axiom union_nil_l : forall A (i : IntMap.IntMap A),
    IntMap.union IntMap.Nil i = i.

Axiom union_nil_r : forall A (i : IntMap.IntMap A),
    IntMap.union i IntMap.Nil = i.
*)
(*
Axiom difference_self : forall A (i : IntMap.IntMap A),
    IntMap.difference i i = IntMap.empty.
*)

Lemma difference_nil_r : forall A B (i : IntMap.IntMap A),
    IntMap.difference i (@IntMap.empty B) = i.
Proof.
  intros. destruct_IntMap.
  unfold IntMap.empty, IntMap.difference.
  apply subset_eq_compat.
  eapply difference_nil_r.
  eassumption.
Qed.

Lemma difference_nil_l : forall B A (i : IntMap.IntMap A),
    IntMap.difference (@IntMap.empty B) i =
    (@IntMap.empty B).
Proof.
  intros. destruct_IntMap.
  unfold IntMap.empty, IntMap.difference.
  apply subset_eq_compat.
  eapply difference_nil_l.
  eassumption.
Qed.

(*
Axiom difference_Tip_member:
  forall A (i : IntMap.IntMap A) (n : IntMap.Key),
    (IntMap.member n i) ->
    forall x:A, IntMap.difference
        (IntMap.Tip n x) i = IntMap.Nil.

Axiom difference_Tip_non_member:
    forall A (i : IntMap.IntMap A) (n : IntMap.Key),
      (IntMap.member n i) = false ->
      forall x : A, IntMap.difference (IntMap.Tip n x) i =
        IntMap.Tip n x.
*)

(* Do we need to know that f respects == for A ? *)
Lemma filter_comp : forall A `{EqLaws A} f f' (i : IntMap.IntMap A),
    IntMap.filter f (IntMap.filter f' i) ==
    IntMap.filter (fun v => f v && f' v) i.
Proof.
  intros. eapply filter_comp. destruct_IntMap.
Qed.

(*
Axiom filter_insert: forall A f key (v:A) i,
  IntMap.filter f (IntMap.insert key v i) =
  (if (f v)
   then IntMap.insert key v (IntMap.filter f i)
   else IntMap.filter f i).
*)

Lemma lookup_filterWithKey :
  forall b key (val:b) m f, IntMap.lookup key (IntMap.filterWithKey f m) = Some val ->
                       IntMap.lookup key m = Some val.
Proof.
  intros. eapply lookup_filterWithKey with (f0:=f); destruct_IntMap.
  intros i j Heq. f_equal. apply /Eq_eq. assumption.
Qed.

Lemma filter_true : forall (A:Type) `{EqLaws A} (m:IntMap.IntMap A),
    IntMap.filter (const true) m == m.
Proof.
  intros. eapply filter_true; destruct_IntMap.
Qed.

Lemma lookup_intersection :
  forall a b key (val1:a)
    (m1 : IntMap.IntMap a) (m2 : IntMap.IntMap b),
    IntMap.lookup key m1 = Some val1 /\
    (exists (val2:b), IntMap.lookup key m2 = Some val2) <->
    IntMap.lookup key (IntMap.intersection m1 m2) = Some val1.
Proof.
  intros. eapply lookup_intersection; destruct_IntMap.
Qed.

Lemma lookup_union :
  forall (A:Type) key (val:A) (m1 m2: IntMap.IntMap A),
    (IntMap.lookup key m1 = Some val \/ (IntMap.lookup key m1 = None /\ IntMap.lookup key m2 = Some val)) <->
    IntMap.lookup key (IntMap.union m1 m2) = Some val.
Proof.
  intros. eapply lookup_union; destruct_IntMap.
Qed.

Lemma lookup_partition :
  forall (A:Type) key (val:A) (m m': IntMap.IntMap A) (P: A -> bool),
    ((m' = fst (IntMap.partition P m) \/
      m' = snd (IntMap.partition P m)) /\
     IntMap.lookup key m' = Some val) ->
    IntMap.lookup key m  = Some val.
Proof.
  intros. destruct_IntMap.
  eapply lookup_partition with (P0:=P); try eassumption.
  unfold IntMap.partition in H; intuition.
  - left. inversion H; reflexivity.
  - right. inversion H; reflexivity.
Qed.

(*
Axiom lookup_partition :
  forall (key : IntMap.Key) (b : Type) (i left right: IntMap b)(f:b -> bool)(y : b),
    lookup key i = Some y ->
    (left, right) = partition f i ->
    lookup key left = Some y \/ lookup key right = Some y.
*)
(*
Axiom lookup_union_None:
  forall (A : Type)
    (key : IntMap.Key)
    (m1 m2 : IntMap.IntMap A),
    IntMap.lookup key m1 = None /\
    IntMap.lookup key m2 = None <->
    IntMap.lookup key
             (IntMap.union m1 m2) = None.
*)

Lemma lookup_difference_in_snd:
  forall (key : Internal.Key) (b : Type) (i i': IntMap.IntMap b) (y:b),
    IntMap.lookup key i' = Some y ->
    IntMap.lookup key (IntMap.difference i i') = None.
Proof.
  intros. eapply lookup_difference_in_snd; destruct_IntMap.
Qed.

Lemma lookup_difference_not_in_snd:
  forall (key : Internal.Key) (b : Type) (i i': IntMap.IntMap b)(y:b),
    IntMap.lookup key i' = None ->
    IntMap.lookup key (IntMap.difference i i') = IntMap.lookup key i.
Proof.
  intros. eapply lookup_difference_not_in_snd; destruct_IntMap.
Qed.

(* This is a pretty strong property about the representation of
   IntMaps. I hope that it is true. *)
Lemma delete_commute :
  forall (A : Type) `{EqLaws A}
    (kx ky : Internal.Key)
    (i : IntMap.IntMap A),
  IntMap.delete ky (IntMap.delete kx i) ==
  IntMap.delete kx (IntMap.delete ky i).
Proof.
  intros. eapply delete_commute; destruct_IntMap.
Qed.

Lemma intersection_empty :
  forall A B (i : IntMap.IntMap A) (j : IntMap.IntMap B),
    (j = IntMap.empty) ->
    IntMap.null (IntMap.intersection i j).
Proof.
  intros. eapply intersection_empty; destruct_IntMap.
  simpl. inversion H. reflexivity.
Qed.

Lemma null_intersection_non_member: forall b k (v : b)(i1 i2 : IntMap.IntMap b),
  IntMap.null
    (IntMap.intersection i1 (IntMap.insert k v i2)) <->
  IntMap.member k i1 = false /\
  IntMap.null (IntMap.intersection i1 i2).
Proof.
  intros. eapply null_intersection_non_member; destruct_IntMap.
  reflexivity. reflexivity.
Qed.

Lemma disjoint_difference: forall  b (i1 i2 i3 : IntMap.IntMap b),
  IntMap.null (IntMap.intersection i2 i3) ->
  IntMap.null (IntMap.difference i1 i2) ->
  IntMap.null (IntMap.intersection i1 i3).
Proof.
  intros. destruct i2.
  eapply disjoint_difference with (m2:=x); destruct_IntMap.
Qed.

Lemma null_intersection_eq : forall b (x1 x2 y1 y2 : IntMap.IntMap b),
  (forall a, IntMap.member a x1 <-> IntMap.member a y1) ->
  (forall a, IntMap.member a x2 <-> IntMap.member a y2) ->
  IntMap.null (IntMap.intersection x1 x2) = IntMap.null (IntMap.intersection y1 y2).
Proof.
  intros.
  eapply null_intersection_eq; destruct_IntMap.
  unfold IntMap.member in *.
  simpl in *.
  intros a. rewrite HSUtil.bool_eq_iff. eauto.
  unfold IntMap.member in *.
  simpl in *.
  intros a. rewrite HSUtil.bool_eq_iff. eauto.
Qed.

(*
This is a QuickChick setup to test the above axioms
(as bugs easily lurk there).

Unfortunately, we have to wait for
https://github.com/QuickChick/QuickChick/issues/87
to be fixed, as currently the programs that QuickChick extracts to
test stuff do not compile...

From QuickChick Require Import QuickChick.
Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.
From QuickChick Require Import Instances.
Set Warnings "-extraction-opaque-accessed,-extraction".

Global Instance genKey : GenSized IntMap.Key :=
  {| arbitrarySized n := fmap N.of_nat (arbitrarySized n) |}.

Global Instance genIntMap {A} `{GenSized A} : GenSized (IntMap A) :=
  {| arbitrarySized n := fmap IntMap.fromList (arbitrarySized n) |}.

Global Instance shrinkIntMap {A} : Shrink (IntMap A) :=
  {| shrink := fun _ => nil |}.

Global Instance shrinkKey : Shrink IntMap.Key :=
  {| shrink := fun _ => nil |}.

Global Instance showKey : Show IntMap.Key :=
  {| show := fun s => show (N.to_nat s) |}.

Global Instance showIntMap {A} `{Show A} : Show (IntMap A) :=
  {| show := fun s => show (IntMap.toList s) |}.

QuickCheck delete_eq.
*)


(* QuickChick Prelude *)
Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import String List. Open Scope string.

From QuickChick Require Import QuickChick Tactics.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
Import QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

(* End prelude *)

Require Export Poly.

Theorem silly1 : forall (n m o p : nat),
     n = m  ->
     [n;o] = [n;p] ->
     [n;o] = [m;p].
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem silly2 : forall (n m o p : nat),
     n = m  ->
     (forall (q r : nat), q = r -> [q;o] = [r;p]) ->
     [n;o] = [m;p].
Admitted. (* Higher-order *)

Theorem silly3_firsttry : forall (n : nat),
     n = 5 ->
(*     true = beq_nat n 5  -> *)
     beq_nat (S (S n)) 7 = true.
Admitted. (* (*N*) QuickChick silly3_firsttry. *)

Theorem rev_exercise1 : forall (l l' : list nat),
     l = rev l' ->
     l' = rev l.
Admitted. (* (*N*) QuickChick rev_exercise1. *)

Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Admitted. (* (*N*) QuickChick trans_eq. *)

Example trans_eq_example' : forall (a b c d e f : nat),
     [a;b] = [c;d] ->
     [c;d] = [e;f] ->
     [a;b] = [e;f].
Admitted. (* Leo: OUT-OF-SCOPE *)

Example trans_eq_exercise : forall (n m o p : nat),
     m = (minustwo o) ->
     (n + p) = m ->
     (n + p) = (minustwo o).
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem S_injective : forall (n m : nat),
  S n = S m ->
  n = m.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem beq_nat_0_l : forall n,
    0 = n -> n = 0.
Admitted. (* (*N*) QuickChick beq_nat_0_l. *)

Theorem inversion_ex4 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem f_equal : forall (A B : Type) (f: A -> B) (x y: A),
  x = y -> f x = f y.
Admitted. (* Leo: CoArb Weirdness *)

Theorem plus_n_n_injective : forall n m,
     n + n = m + m ->
     n = m.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem double_injective : forall n m,
     double n = double m ->
     n = m.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem beq_id_true : forall (x y : id),
  x = y -> x = y.
Admitted. (* (*N*) QuickChick beq_id_true. *)

(* Leo: Theorem nth_error_after_last: forall (n : nat) (X : Type) (l : list X), *)
Theorem nth_error_after_last: forall  (X : Type) (l : list X) (n : nat),
     length l = n ->
     nth_error l n = None.
Admitted. (* (*N*) QuickChick nth_error_after_last. *)

Definition square n := n * n.

Lemma square_mult : forall n m, square (n * m) = square n * square m.
Admitted. (* QuickChick square_mult *)

Definition foo (x: nat) := 5.

Fact silly_fact_1 : forall m, foo m + 1 = foo (m + 1) + 1.
Admitted. (* QuickChick silly_fact_1. *)

Definition bar x :=
  match x with
  | O => 5
  | S _ => 5
  end.

Fact silly_fact_2 : forall m, bar m + 1 = bar (m + 1) + 1.
Admitted. (* QuickChick silly_fact_2. *)

Definition sillyfun (n : nat) : bool :=
  if beq_nat n 3 then false
  else if beq_nat n 5 then false
  else false.

Theorem sillyfun_false : forall (n : nat),
  sillyfun n = false.
Admitted. (* QuickChick sillyfun_false. *)

Definition sillyfun1 (n : nat) : bool :=
  if beq_nat n 3 then true
  else if beq_nat n 5 then true
  else false.

Theorem sillyfun1_odd : forall (n : nat),
     sillyfun1 n = true ->
     oddb n = true.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem bool_fn_applied_thrice :
  forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Admitted. (* Coarbitrary *)

Theorem beq_nat_sym : forall (n m : nat),
  beq_nat n m = beq_nat m n.
Admitted. (* QuickChick beq_nat_sym. *)

Theorem beq_nat_trans : forall n m p,
  beq_nat n m = true ->
  beq_nat m p = true ->
  beq_nat n p = true.
Admitted. (* Leo: OUT-OF-SCOPE *)

Theorem filter_exercise : forall (X : Type) (test : X -> bool)
                             (x : X) (l lf : list X),
     filter test l = x :: lf ->
     test x = true.
Admitted.