From mathcomp Require Import
  ssreflect eqtype fintype ssrfun ssrbool ssrnat seq ssrint ssrnum ssralg
  finset generic_quotient finfun.
From extructures Require Import ord fmap.
From CoqUtils Require Import hseq word.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Bullet Behavior "Strict Subproofs".

Require Import lib.utils lib.fmap_utils lib.ssr_set_utils.
Require Import common.types common.segment.
Require Import concrete.concrete concrete.int_32.
Require Import symbolic.symbolic symbolic.int_32 symbolic.exec.
Require Import compartmentalization.common compartmentalization.symbolic.
Require Import compartmentalization.isolate_sets.
Require Import os.os.

Require Extraction.

Extraction Language Haskell.

Extract Inductive unit => "()" ["()"].

Extract Inductive prod => "(,)" ["(,)"].
Extract Inductive sigT => "(,)" ["(,)"].
Extract Inductive sigT2 => "(,,)" ["(,,)"].
Extract Constant prod_rect    => "Prelude.uncurry".
Extract Constant prod_uncurry => "Prelude.curry".
Extract Constant sigT_rect    => "Prelude.uncurry".
Extract Constant fst          => "Prelude.fst".
Extract Constant snd          => "Prelude.snd".
Extract Constant projT1       => "Prelude.fst".
Extract Constant projT2       => "Prelude.snd".
(* choice *)
Extract Constant choice.tag_of_pair => "Prelude.id".
Extract Constant choice.pair_of_tag => "Prelude.id".

Extract Inductive bool         => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive sumbool      => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Inductive Bool.reflect => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Constant andb             => "(Prelude.&&)".
Extract Constant orb              => "(Prelude.||)".
Extract Constant xorb             => "(Prelude./=)".
Extract Constant negb             => "Prelude.not".
Extract Constant bool_choice      => "Prelude.id".
Extract Constant Bool.bool_dec    => "(Prelude.==)".
Extract Constant Bool.eqb         => "(Prelude.==)".
Extract Constant Bool.iff_reflect => "Prelude.id".
Extract Constant Bool.reflect_dec => "Prelude.flip Prelude.const".
Extract Constant addb             => "(Prelude./=)". (* addb == xor *)
Extract Constant eqb              => "(Prelude.==)".
Extract Constant isSome           => "Data.Maybe.isJust".
Extract Constant is_inl           => "Data.Either.isLeft".
Extract Constant is_left          => "Prelude.id".
Extract Constant is_inleft        => "Data.Maybe.isJust".
Extract Constant compareb         => "(Prelude.$)".

(* Like booleans, but super important! *)
Extract Inductive reflect => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
Extract Constant introP   => "Prelude.id".
Extract Constant sumboolP => "Prelude.id".
Extract Constant idP      => "Prelude.id".
Extract Constant idPn     => "Prelude.not".
Extract Constant negP     => "Prelude.not".
Extract Constant negPn    => "Prelude.id".
Extract Constant negPf    => "Prelude.not".
Extract Constant andP     => "(Prelude.&&)".
Extract Constant and3P    => "\b1 b2 b3 -> b1 Prelude.&& b2 Prelude.&& b3".
Extract Constant and4P    => "\b1 b2 b3 b4 -> b1 Prelude.&& b2 Prelude.&& b3 Prelude.&& b4".
Extract Constant and5P    => "\b1 b2 b3 b4 b5 -> b1 Prelude.&& b2 Prelude.&& b3 Prelude.&& b4 Prelude.&& b5".
Extract Constant orP      => "(Prelude.||)".
Extract Constant or3P     => "\b1 b2 b3 -> b1 Prelude.|| b2 Prelude.|| b3".
Extract Constant or4P     => "\b1 b2 b3 b4 -> b1 Prelude.|| b2 Prelude.|| b3 Prelude.|| b4".
Extract Constant nandP    => "\b1 b2 -> Prelude.not (b1 Prelude.&& b2)".
Extract Constant norP     => "\b1 b2 -> Prelude.not (b1 Prelude.|| b2)".
Extract Constant addbP    => "(Prelude./=)".
Extract Constant compareP => "(Prelude.$)".

Extract Inductive alt_spec => "Prelude.Bool" ["Prelude.True" "Prelude.False"].

Extract Inductive option => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Inductive sumor  => "Prelude.Maybe" ["Prelude.Just" "Prelude.Nothing"].
Extract Constant option_rect    => "Prelude.flip Prelude.maybe".
Extract Constant option_map     => "Prelude.fmap".
Extract Constant Option.apply   => "Prelude.flip Prelude.maybe".
Extract Constant Option.default => "Data.Maybe.fromMaybe".
Extract Constant Option.bind    => "(Prelude.=<<)".
Extract Constant Option.map     => "Prelude.fmap".

Extract Inductive sum => "Prelude.Either" ["Prelude.Left" "Prelude.Right"].
Extract Constant sum_rect => "Prelude.either".

Extract Inductive list => "[]" ["[]" "(:)"].
Extract Constant length  => "Data.List.genericLength".
Extract Constant app     => "(Prelude.++)".
(* seq *)
Extract Constant size    => "Data.List.genericLength".
Extract Constant nilp    => "Prelude.null".
Extract Constant nilP    => "Prelude.null".
Extract Constant nseq    => "Prelude.replicate Prelude.. Prelude.fromInteger".
Extract Constant cat     => "(Prelude.++)".
Extract Constant filter  => "Prelude.filter".
Extract Constant has     => "Prelude.any".
Extract Constant all     => "Prelude.all".
Extract Constant drop    => "Prelude.drop Prelude.. Prelude.fromInteger".
Extract Constant take    => "Prelude.take Prelude.. Prelude.fromInteger".
Extract Constant rev     => "Prelude.reverse".
Extract Constant map     => "Prelude.map".
Extract Constant pmap    => "Data.Maybe.mapMaybe".
Extract Constant iota    => "\f t -> [f .. f Prelude.+ t Prelude.- 1]".
Extract Constant foldr   => "Prelude.foldr".
Extract Constant sumn    => "Prelude.sum".
Extract Constant foldl   => "Data.List.foldl'".
Extract Constant scanl   => "Prelude.scanl".
Extract Constant zip     => "Prelude.zip".
Extract Constant flatten => "Prelude.concat".
(* choice *)
Extract Constant choice.seq_of_opt => "Prelude.maybe [] Prelude.return".

Extract Inductive comparison  => "Prelude.Ordering" ["Prelude.EQ" "Prelude.LT" "Prelude.GT"].
Extract Inductive CompareSpec => "Prelude.Ordering" ["Prelude.EQ" "Prelude.LT" "Prelude.GT"].
  (* Like `comparison`, but with proofs -- except those have been erased *)

Extract Inductive nat => "Prelude.Integer" ["(0 :: Prelude.Integer)" "(Prelude.+ 1)"]
                         "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))".
Extract Constant Peano.pred      => "\x -> Prelude.max (x Prelude.- 1) 0".
Extract Constant Peano.plus      => "(Prelude.+)".
Extract Constant Peano.minus     => "\x y -> Prelude.max (x Prelude.- y) 0".
Extract Constant Peano.mult      => "(Prelude.*)".
Extract Constant Peano.max       => "Prelude.max".
Extract Constant Peano.min       => "Prelude.min".
(* ssrnat *)
Extract Constant eqn             => "(Prelude.==)".
Extract Constant addn_rec        => "(Prelude.+)".
Extract Constant addn            => "(Prelude.+)".
Extract Constant subn_rec        => "\x y -> Prelude.max (x Prelude.- y) 0".
Extract Constant subn            => "\x y -> Prelude.max (x Prelude.- y) 0".
Extract Constant leq             => "(Prelude.<=)".
Extract Constant maxn            => "Prelude.max".
Extract Constant minn            => "Prelude.min".
Extract Constant muln_rec        => "(Prelude.*)".
Extract Constant muln            => "(Prelude.*)".
Extract Constant expn_rec        => "(Prelude.^)".
Extract Constant expn            => "(Prelude.^)".
Extract Constant fact_rec        => "Prelude.product Prelude.. Prelude.enumFromTo 1".
Extract Constant factorial       => "Prelude.product Prelude.. Prelude.enumFromTo 1".
Extract Constant nat_of_bool     => "\b -> (if b then 1 else 0 :: Prelude.Integer)".
Extract Constant odd             => "Prelude.odd".
Extract Constant double_rec      => "(2 Prelude.*)".
Extract Constant double          => "(2 Prelude.*)".
Extract Constant half            => "(`Prelude.quot` 2)".
Extract Constant uphalf          => "\x -> (x Prelude.+ 1) `Prelude.quot` 2".
Extract Constant NatTrec.add     => "(Prelude.+)".
Extract Constant NatTrec.add_mul => "\x y acc -> (x Prelude.* y) Prelude.+ acc".
Extract Constant NatTrec.mul     => "(Prelude.*)".
Extract Constant NatTrec.mul_exp => "\x y acc -> (x Prelude.^ y) Prelude.* acc".
Extract Constant NatTrec.exp     => "(Prelude.^)".
Extract Constant NatTrec.odd     => "Prelude.odd".
Extract Constant NatTrec.double  => "(2 Prelude.*)".
Extract Constant nat_of_pos      => "Prelude.id".
Extract Constant nat_of_bin      => "Prelude.id".
Extract Constant bin_of_nat      => "Prelude.id".
(* ssr div *)
Extract Constant div.edivn    => "\x y -> if y Prelude.== 0 then (0,x) else x `Prelude.quotRem` y".
Extract Constant div.divn     => "\x y -> if y Prelude.== 0 then 0     else x `Prelude.quot`    y".
Extract Constant div.modn     => "\x y -> if y Prelude.== 0 then x     else x `Prelude.rem`     y".
Extract Constant div.gcdn_rec => "Prelude.gcd".
Extract Constant div.gcdn     => "Prelude.gcd".
Extract Constant div.lcmn     => "Prelude.lcm".

Extract Inductive BinNums.positive =>
  "Prelude.Integer"
  ["((Prelude.+ 1) Prelude.. (2 Prelude.*))"
   "(2 Prelude.*)"
   "(1 :: Prelude.Integer)"]
  "(\fxI fxO fxH p -> if p Prelude.== 1 then fxH p else (if Data.Bits.testBit p 0 then fxI else fxO) (p `Data.Bits.shiftR` 1))".
Extract Inductive BinNums.N =>
  "Prelude.Integer" ["(0 :: Prelude.Integer)" "Prelude.id"]
  "(\fN0 fNpos n -> if n Prelude.== 0 then fN0 () else fNpos n)".
Extract Inductive BinNums.Z =>
  "Prelude.Integer" ["(0 :: Prelude.Integer)" "Prelude.id" "Prelude.negate"]
  "(\fZ0 fZpos fZneg z -> case z `Prelude.compare` 0 of { Prelude.GT -> fZpos z ; Prelude.EQ -> fZ0 () ; Prelude.LT -> fZneg (- z) })".

Extract Constant BinPos.Pos.succ         => "(Prelude.+ 1)".
Extract Constant BinPos.Pos.add          => "(Prelude.+)".
Extract Constant BinPos.Pos.add_carry    => "\x y -> x Prelude.+ y Prelude.+ 1".
Extract Constant BinPos.Pos.pred_double  => "\x -> (2 Prelude.* x) Prelude.- 1".
Extract Constant BinPos.Pos.pred         => "\x -> Prelude.max (x Prelude.- 1) 1".
Extract Constant BinPos.Pos.pred_N       => "Prelude.subtract 1".
Extract Constant BinPos.Pos.sub          => "\x y -> Prelude.max (x Prelude.- y) 1".
Extract Constant BinPos.Pos.mul          => "(Prelude.*)".
Extract Constant BinPos.Pos.pow          => "(Prelude.^)".
Extract Constant BinPos.Pos.square       => "(Prelude.^ 2)".
Extract Constant BinPos.Pos.div2         => "\x -> Prelude.max (x `Prelude.quot` 2) 1".
Extract Constant BinPos.Pos.div2_up      => "\x -> (x Prelude.+ 1) `Prelude.quot` 2".
Extract Constant BinPos.Pos.compare      => "Prelude.compare".
Extract Constant BinPos.Pos.min          => "Prelude.min".
Extract Constant BinPos.Pos.max          => "Prelude.max".
Extract Constant BinPos.Pos.eqb          => "(Prelude.==)".
Extract Constant BinPos.Pos.leb          => "(Prelude.<=)".
Extract Constant BinPos.Pos.ltb          => "(Prelude.<)".
Extract Constant BinPos.Pos.gcd          => "Prelude.gcd".
Extract Constant BinPos.Pos.Nsucc_double => "\x -> 2 Prelude.* x Prelude.+ 1".
Extract Constant BinPos.Pos.Ndouble      => "(2 Prelude.*)".
Extract Constant BinPos.Pos.lor          => "(Data.Bits..|.)".
Extract Constant BinPos.Pos.land         => "(Data.Bits..&.)".
Extract Constant BinPos.Pos.ldiff        => "\x y -> x Data.Bits..&. Data.Bits.complement y".
Extract Constant BinPos.Pos.lxor         => "Data.Bits.xor".
Extract Constant BinPos.Pos.shiftl_nat   => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant BinPos.Pos.shiftr_nat   => "\x s -> Prelude.max (x `Data.Bits.shiftR` (Prelude.fromInteger s)) 1".
Extract Constant BinPos.Pos.shiftl       => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant BinPos.Pos.shiftr       => "\x s -> Prelude.max (x `Data.Bits.shiftR` (Prelude.fromInteger s)) 1".
Extract Constant BinPos.Pos.testbit_nat  => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant BinPos.Pos.testbit      => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant BinPos.Pos.to_nat       => "Prelude.id".
Extract Constant BinPos.Pos.of_nat       => "Prelude.max 1".
Extract Constant BinPos.Pos.of_succ_nat  => "(Prelude.+ 1)".
Extract Constant BinPos.Pos.eq_dec       => "(Prelude.==)".

Extract Constant BinNat.N.zero         => "0 :: Prelude.Integer".
Extract Constant BinNat.N.one          => "1 :: Prelude.Integer".
Extract Constant BinNat.N.two          => "2 :: Prelude.Integer".
Extract Constant BinNat.N.succ_double  => "\x -> 2 Prelude.* x Prelude.+ 1".
Extract Constant BinNat.N.double       => "(2 Prelude.*)".
Extract Constant BinNat.N.succ         => "(Prelude.+ 1)".
Extract Constant BinNat.N.pred         => "\x -> Prelude.max (x Prelude.- 1) 0".
Extract Constant BinNat.N.succ_pos     => "(Prelude.+ 1)".
Extract Constant BinNat.N.add          => "(Prelude.+)".
Extract Constant BinNat.N.sub          => "\x y -> Prelude.max (x Prelude.- y) 0".
Extract Constant BinNat.N.mul          => "(Prelude.*)".
Extract Constant BinNat.N.compare      => "Prelude.compare".
Extract Constant BinNat.N.eqb          => "(Prelude.==)".
Extract Constant BinNat.N.leb          => "(Prelude.<=)".
Extract Constant BinNat.N.ltb          => "(Prelude.<)".
Extract Constant BinNat.N.min          => "Prelude.min".
Extract Constant BinNat.N.max          => "Prelude.max".
Extract Constant BinNat.N.div2         => "(`Prelude.quot` 2)".
Extract Constant BinNat.N.even         => "Prelude.even".
Extract Constant BinNat.N.odd          => "Prelude.odd".
Extract Constant BinNat.N.pow          => "(Prelude.^)".
Extract Constant BinNat.N.square       => "(Prelude.^ 2)".
Extract Constant BinNat.N.pos_div_eucl => "\x y -> if y Prelude.== 0 then (0,x) else x `Prelude.quotRem` y".
Extract Constant BinNat.N.div_eucl     => "\x y -> if y Prelude.== 0 then (0,x) else x `Prelude.quotRem` y".
Extract Constant BinNat.N.div          => "Prelude.quot".
Extract Constant BinNat.N.modulo       => "Prelude.rem".
Extract Constant BinNat.N.gcd          => "Prelude.gcd".
Extract Constant BinNat.N.lor          => "(Data.Bits..|.)".
Extract Constant BinNat.N.land         => "(Data.Bits..&.)".
Extract Constant BinNat.N.ldiff        => "\x y -> x Data.Bits..&. Data.Bits.complement y".
Extract Constant BinNat.N.lxor         => "Data.Bits.xor".
Extract Constant BinNat.N.shiftl_nat   => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant BinNat.N.shiftr_nat   => "\x s -> x `Data.Bits.shiftR` (Prelude.fromInteger s)".
Extract Constant BinNat.N.shiftl       => "\x s -> x `Data.Bits.shiftL` (Prelude.fromInteger s)".
Extract Constant BinNat.N.shiftr       => "\x s -> x `Data.Bits.shiftR` (Prelude.fromInteger s)".
Extract Constant BinNat.N.testbit_nat  => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant BinNat.N.testbit      => "\x b -> Data.Bits.testBit x (Prelude.fromInteger b)".
Extract Constant BinNat.N.to_nat       => "Prelude.id".
Extract Constant BinNat.N.of_nat       => "Prelude.id".
Extract Constant BinNat.N.eq_dec       => "(Prelude.==)".
Extract Constant BinNat.N.lcm          => "Prelude.lcm".
Extract Constant BinNat.N.setbit       => "\x b -> Data.Bits.setBit x (Prelude.fromInteger b)".
Extract Constant BinNat.N.clearbit     => "\x b -> Data.Bits.clearBit x (Prelude.fromInteger b)".

Extract Inductive int => "Prelude.Integer"
                         ["Prelude.id" "(Prelude.negate Prelude.. (Prelude.+1))"]
                         "(\fP fN n -> if n Prelude.>= 0 then fP n else fN (Prelude.abs n Prelude.- 1))".
Extract Constant intZmod.addz   => "(Prelude.+)".
Extract Constant intZmod.oppz   => "Prelude.negate".
Extract Constant intRing.mulz   => "(Prelude.*)".
Extract Constant absz           => "Prelude.abs".
Extract Constant intOrdered.lez => "(Prelude.<=)".
Extract Constant intOrdered.ltz => "(Prelude.<)".
(* intmul? (no)  exprz? (maybe)  sgz? (probably not) *)
(* Extract Constant int_eqMixin    => "Eqtype.coq_CanEqMixin (Prelude.==) (unsafeCoerce natsum_of_int) (unsafeCoerce int_of_natsum)". *)
(* ^ The above doesn't work because `(==)' needs to be an eqtype.  Thus,
   equality will be a bit slower than it should be. *)

Extract Constant intdiv.divz => "\x y -> unsafeCoerce (if y Prelude.== 0 then 0 else x `Prelude.div` y)". (* I cannot BELIEVE I need unsafeCoerce here. *)
Extract Constant intdiv.modz => "\x y -> if y Prelude.== 0 then x else x `Prelude.mod` Prelude.abs y".

Extract Inductive rat.rat => "Prelude.Rational" ["(Prelude.uncurry (Data.Ratio.%))"]
                             "(\f q -> f (Data.Ratio.numerator q, Data.Ratio.denominator q))".
Extract Constant rat.valq   => "\q -> (Data.Ratio.numerator q, Data.Ratio.denominator q)".
Extract Constant rat.ratz   => "Prelude.fromInteger".
Extract Constant rat.numq   => "Data.Ratio.numerator".
Extract Constant rat.denq   => "Data.Ratio.denominator".
Extract Constant rat.fracq  => "Prelude.uncurry (Data.Ratio.%)".
Extract Constant rat.zeroq  => "0".
Extract Constant rat.oneq   => "1".
Extract Constant rat.addq   => "(Prelude.+)".
Extract Constant rat.oppq   => "Prelude.negate".
Extract Constant rat.mulq   => "(Prelude.*)".
Extract Constant rat.invq   => "Prelude.recip".
Extract Constant rat.subq   => "(Prelude.-)".
Extract Constant rat.divq   => "\x y -> if y Prelude.== 0 then 0 else x Prelude./ y".
Extract Constant rat.le_rat => "(Prelude.<=)".
Extract Constant rat.lt_rat => "(Prelude.<)".

(* The `zmodp' stuff for Ordinals should mostly extract efficiently!  I'm not
   sure about `Zp_inv', though, in particular its use of `div.egcdn'. *)

(* Word arithmetic is left alone -- the bitwise hacks don't seem worth it, and
   we can't just extract `word 32' to `Int32', so... yeah.  We do deal with the
   bitwise stuff to avoid finfuns, though.  *)

Extract Constant negw => "\k (Word w) -> as_word k (Data.Bits.complement w)".
Extract Constant andw => "\_ (Word w1) (Word w2) -> Word (w1  Data.Bits..&.  w2)".
Extract Constant orw  => "\_ (Word w1) (Word w2) -> Word (w1  Data.Bits..|.  w2)".
Extract Constant xorw => "\_ (Word w1) (Word w2) -> Word (w1 `Data.Bits.xor` w2)".

Extract Inductive set_type => "Finset.Coq_set_type"
                              ["(finsetAbstract ""FinSet constructor"")"]
                              "(finsetAbstract ""FinSet case"")".
Extract Constant set_type_rect    => "finsetAbstract ""set_type_rect""".
Extract Constant set_type_rec     => "finsetAbstract ""set_type_rec""".
Extract Constant finfun_of_set    => "finsetAbstract ""finfun_of_set""".
Extract Constant SetDef.finset    => "finsetAbstract ""SetDef.finset""".
Extract Constant Imset.imset      => "finsetAbstract ""Imset.imset""".
Extract Constant Imset.imset2     => "finsetAbstract ""Imset.imset2""".
Extract Constant preimset         => "finsetAbstract ""preimset""".
(*
Extract Constant set_subType      => "finsetAbstract ""set_subType""".
Extract Constant set_choiceMixin  => "finsetAbstract ""set_choiceMixin""".
Extract Constant set_choiceType   => "finsetAbstract ""set_choiceType""".
Extract Constant set_countMixin   => "finsetAbstract ""set_countMixin""".
Extract Constant set_countType    => "finsetAbstract ""set_countType""".
Extract Constant set_subCountType => "finsetAbstract ""set_subCountType""".
Extract Constant set_finMixin     => "finsetAbstract ""set_finMixin""".
Extract Constant set_finType      => "finsetAbstract ""set_finType""".
Extract Constant set_subFinType   => "finsetAbstract ""set_subFinType""".
Extract Constant set_predType     => "finsetAbstract ""set_predType""".
...
*)

Extract Constant set_eqMixin => "withFintypeOrd' (Eqtype.equality__mixin (Prelude.==) (finsetAbstract ""set_eqMixin/eqP""))".

Extract Constant SetDef.pred_of_set => "withFintypeOrd' (unsafeCoerce Prelude.. Prelude.flip Data.Set.member)".

Extract Constant set0     => "\_ -> Data.Set.empty".
Extract Constant setTfor  => "finsetFinite ""setTfor""".
Extract Constant set1     => "\_ x -> Data.Set.singleton (unitAny x)".
Extract Constant setU     => "withFintypeOrd' Data.Set.union".
Extract Constant setI     => "withFintypeOrd' Data.Set.intersection".
Extract Constant setC     => "finsetFinite ""setC""".
Extract Constant setD     => "withFintypeOrd' Data.Set.difference".
Extract Constant ssetI    => "withFintypeOrd' (\xss ys -> flattenedSet (Data.Set.filter (`Data.Set.isSubsetOf` ys) (nestedSet xss)))".
Extract Constant powerset => "withFintypeOrd' (\s -> flattenedSet (setPowerset s))".
Extract Constant setX     => "\_ _ xs ys ->
  unsafeCoerce (Data.Set.fromDistinctAscList [ (x,y) | x <- Data.Set.toAscList xs
                                                     , y <- Data.Set.toAscList ys ])".
  (* Due to Dan Weston's mailing list post at
     https://mail.haskell.org/pipermail/haskell-cafe/2007-August/029859.html;
     the proof obligation for `fromDistinctAscList' is fulfilled by
     construction *)

(* Not confident about the `unsafeCoerce' in this one *)
Extract Constant set_0Vmem => "\_ s -> if Data.Set.null s then Prelude.Left () else Prelude.Right (unsafeCoerce (Data.Set.findMin s))".

(* Not sure about cover, pblock, trivIset, partition, is_transversal, transversal *)
(* Also not sure about minset and maxset *)

(* Cardinality *will* break, too *)

(* `enum_set` is a specialized `enum` -- see `lib/ssr_set_utils.v` for why we
   need it.  Since `lib.ssr_set_utils` is so small, it apparently doesn't have
   `unsafeCoerce`, so we borrow one.*)
Extract Constant enum_set => "\_ ->
  (Finset.unsafeCoerce :: [GHC.Base.Any] -> [()]) Prelude.. Data.Set.toList".

(* We extract `atom` specially just for a better name.  We could do this for
   other types (e.g. `Coq_binop` -> `Binop`, but atoms get more use and really
   benefit from the fancy constructor. *)
Extract Inductive atom  => "Types.Atom" ["(Types.:@)"].

(* `isolate_get_range' needs to be fixed up --
   `[set i : mword mt in some_predicate]` uses the `finfun' machinery!  So we
   just reimplement a mix of the extracted version (in the `let`), the Coq
   version (using Haskell's `do` notation), and replace the `[set i ...]` stuff
   with a Haskell `[l..h]` range!  We can safely do this by moving in and out of
   `Coq_word` without checks, since everything between `l` and `h` is guaranteed
   to be a valid word.  Since `compartmentalization.isolate_sets` is so small,
   it apparently doesn't have `__`, so we borrow one. *)
Extract Constant isolate_get_range => "\mt to_word m p -> do {
  let { wsz      = Types.word_size mt ;
        get_m    = Partmap.getm (Word.word_ordType wsz) m Prelude.. unsafeCoerce ;
        add1     = Prelude.flip (Word.addw wsz) (Word.onew wsz) ;
        to_hsInt = Word.ord_of_word Types.__ Prelude.. to_word ;
        fromList = Finset.forgetToCoqSet Prelude.. Data.Set.fromList } ;
  low  <- get_m p ;
  high <- get_m (add1 p) ;
  Prelude.Just (fromList (Prelude.map Word.Word [to_hsInt low .. to_hsInt high])) }".

(* eqtypes get included comparator functions -- the definition of the type is
   stored in extra/eqtype.hs *)
Extract Inductive Equality.mixin_of => "Eqtype.Equality__Coq_mixin_of" ["Eqtype.equality__mixin"]
                                       "(\f em -> case em of Eqtype.Equality__Mixin eqb eqP _ -> f eqb eqP)".
Extract Constant sub_eqMixin => "\t p sT ->
  Equality__Mixin
    (\x y -> eq_op t (val p sT x) (val p sT y))
    (val_eqP t p sT)
    (\x y -> compare_op t (val p sT x) (val p sT y))".
Extract Constant SubEqMixin => "\t p sT ->
  let {vP = val_eqP t p sT} in
  case sT of {
   SubType v sub p0 ->
     Equality__Mixin
       (\x y -> eq_op t (v x) (v y))
       vP
       (\x y -> compare_op t (v x) (v y))
  }".
Extract Constant sig_eqMixin => "\t p ->
  Equality__Mixin
    (\x y -> eq_op t (Specif.proj1_sig x) (Specif.proj1_sig y))
    (unsafeCoerce (val_eqP t (\x -> p x) (sig_subType p)))
    (\x y -> compare_op t (Specif.proj1_sig x) (Specif.proj1_sig y))".
Extract Constant prod_eqMixin => "\t1 t2 ->
  Equality__Mixin
    (Ssrbool.rel_of_simpl_rel (pair_eq t1 t2))
    (pair_eqP t1 t2)
    (\(x1,x2) (y1,y2) -> compare_op t1 x1 y1 Data.Monoid.<> compare_op t2 x2 y2)".
Extract Constant option_eqMixin => "\t ->
  Equality__Mixin (opt_eq t) (opt_eqP t)
    (\mx my -> case (mx,my) of {
                 (Prelude.Nothing, Prelude.Nothing) -> Prelude.EQ;
                 (Prelude.Nothing, Prelude.Just _)  -> Prelude.LT;
                 (Prelude.Just _,  Prelude.Nothing) -> Prelude.GT;
                 (Prelude.Just x,  Prelude.Just y)  -> compare_op t x y})".
Extract Constant tag_eqMixin => "\i t_ ->
  Equality__Mixin (tag_eq i t_) (tag_eqP i t_)
                  (\x1 x2 -> compare_op i             (tag x1)    (tag x2) Data.Monoid.<>
                             compare_op (t_ (tag x1)) (tagged x1) (tagged_as i x1 x2))".
Extract Constant sum_eqMixin => "\t1 t2 ->
  Equality__Mixin (sum_eq t1 t2) (sum_eqP t1 t2)
    (\x12 y12 -> case (x12, y12) of {
                   (Prelude.Left  x1, Prelude.Left  y1) -> compare_op t1 x1 y1;
                   (Prelude.Right x2, Prelude.Right y2) -> compare_op t2 x2 y2;
                   (Prelude.Left  _,  Prelude.Right _)  -> Prelude.LT;
                   (Prelude.Right _,  Prelude.Left  _)  -> Prelude.GT })".

(* The type `finfun_type` is horribly inefficient, but I don't believe we ever
   use it, as long as we extract sets properly. *)
Extract Constant finfun.eqMixin => "\aT rT ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op
      (Tuple.tuple_eqType
        (Fintype._CardDef__card aT
          (Ssrbool.mem Ssrbool.predPredType
            (Ssrbool.sort_of_simpl_pred Ssrbool.pred_of_argType))) rT)
      (unsafeCoerce (fgraph aT x)) (unsafeCoerce (fgraph aT y)))
    (unsafeCoerce
      (Eqtype.val_eqP
        (Tuple.tuple_eqType
          (Fintype._CardDef__card aT
            (Ssrbool.mem Ssrbool.predPredType
              (Ssrbool.sort_of_simpl_pred Ssrbool.pred_of_argType))) rT)
        (\x -> Prelude.True) (unsafeCoerce (finfun_subType aT))))
    (\x y ->
      Eqtype.compare_op
        (Tuple.tuple_eqType
          (Fintype._CardDef__card aT
            (Ssrbool.mem Ssrbool.predPredType
              (Ssrbool.sort_of_simpl_pred Ssrbool.pred_of_argType))) rT)
        (unsafeCoerce (fgraph aT x)) (unsafeCoerce (fgraph aT y)))".

Extract Constant fingroup.group_eqMixin => "\gT ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op (group_set_eqType (_FinGroup__base gT))
      (unsafeCoerce (gval gT x)) (unsafeCoerce (gval gT y)))
    (unsafeCoerce
      (Eqtype.val_eqP (group_set_eqType (_FinGroup__base gT))
        (unsafeCoerce (group_set gT)) (unsafeCoerce (group_subType gT))))
    (\x y ->
      Eqtype.compare_op (group_set_eqType (_FinGroup__base gT))
        (unsafeCoerce (gval gT x)) (unsafeCoerce (gval gT y)))".

Extract Constant fingroup.subg_eqMixin => "\gT g ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op (_FinGroup__arg_eqType (_FinGroup__base gT)) (sgval gT g x)
      (sgval gT g y))
    (unsafeCoerce
      (Eqtype.val_eqP (_FinGroup__arg_eqType (_FinGroup__base gT)) (\x ->
        Ssrbool.in_mem x
          (Ssrbool.mem Ssrbool.predPredType
            (Finset._SetDef__pred_of_set
              (_FinGroup__arg_finType (_FinGroup__base gT)) (gval gT g))))
        (subg_subType gT g)))
    (\x y ->
      Eqtype.compare_op (_FinGroup__arg_eqType (_FinGroup__base gT)) (sgval gT g x)
        (sgval gT g y))".

Extract Constant choice.tree_eqMixin => "\t ->
  let { (<=>) :: GenTree__Coq_tree Eqtype.Equality__Coq_sort
              -> GenTree__Coq_tree Eqtype.Equality__Coq_sort
              -> Prelude.Ordering
      ; GenTree__Leaf x    <=> GenTree__Leaf y    = Eqtype.compare_op t x y
      ; GenTree__Leaf _    <=> GenTree__Node _ _  = Prelude.LT
      ; GenTree__Node _ _  <=> GenTree__Leaf _    = Prelude.GT
      ; GenTree__Node m xs <=> GenTree__Node n ys =
          (m `Prelude.compare` n) Data.Monoid.<>
          (Eqtype.compare_op
            (unsafeCoerce (Seq.seq_eqMixin (unsafeCoerce (tree_eqMixin t))))
            (unsafeCoerce xs)
            (unsafeCoerce ys)) }
  in Data.Reflection.Constraint.providing (Data.Reflection.Constraint.Ord (<=>))
       (Eqtype.coq_PcanEqMixin
          (Seq.seq_eqType (Eqtype.sum_eqType Ssrnat.nat_eqType t))
          (unsafeCoerce _GenTree__encode) (unsafeCoerce _GenTree__decode))".

Extract Constant fintype.seq_sub_eqMixin => "\t s ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op (Choice._Choice__eqType t) (ssval t s x) (ssval t s y))
    (unsafeCoerce
      (Eqtype.val_eqP (Choice._Choice__eqType t) (\x ->
        Ssrbool.in_mem x
          (Ssrbool.mem (Seq.seq_predType (Choice._Choice__eqType t))
            (unsafeCoerce s))) (seq_sub_subType t s)))
    (\x y -> Eqtype.compare_op (Choice._Choice__eqType t) (ssval t s x) (ssval t s y))".

Extract Constant hseq.hseq_eqMixin => "\t_ idx ->
  Eqtype.Equality__Mixin (hseq_eq t_ idx) (hseq_eqP t_ idx) (hseq_compare t_ idx)".
Extract Constant hseq.HSeqChoiceType.hseq_choiceMixin =>
  "GHC.Stack.errorWithStackTrace ""_HSeqChoiceType__hseq_choiceMixin: failed to compile with infinite type errors""".

Extract Constant poly.polynomial_eqMixin => "\r ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op (Seq.seq_eqType (Ssralg._GRing__Ring__eqType r))
      (unsafeCoerce (polyseq r x)) (unsafeCoerce (polyseq r y)))
    (unsafeCoerce
      (Eqtype.val_eqP (Seq.seq_eqType (Ssralg._GRing__Ring__eqType r)) (\x ->
        Datatypes.negb
          (Eqtype.eq_op (Ssralg._GRing__Ring__eqType r)
            (Seq.last (Ssralg._GRing__one r) (unsafeCoerce x))
            (Ssralg._GRing__zero (Ssralg._GRing__Ring__zmodType r))))
        (unsafeCoerce (polynomial_subType r))))
    (\x y ->
      Eqtype.compare_op (Seq.seq_eqType (Ssralg._GRing__Ring__eqType r))
        (unsafeCoerce (polyseq r x)) (unsafeCoerce (polyseq r y)))".

Extract Constant quotient.coset_eqMixin => "\gT a ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op (Fingroup.group_set_eqType (Fingroup._FinGroup__base gT))
      (unsafeCoerce (set_of_coset gT a x))
      (unsafeCoerce (set_of_coset gT a y)))
    (unsafeCoerce
      (Eqtype.val_eqP
        (Fingroup.group_set_eqType (Fingroup._FinGroup__base gT))
        (Ssrbool.pred_of_simpl (coset_range gT a))
        (unsafeCoerce (coset_subType gT a))))
    (\x y ->
      Eqtype.compare_op (Fingroup.group_set_eqType (Fingroup._FinGroup__base gT))
        (unsafeCoerce (set_of_coset gT a x))
        (unsafeCoerce (set_of_coset gT a y)))".

Extract Constant seq_eqMixin => "\t ->
  let {[]     <=> []     = Prelude.EQ;
       []     <=> (_:_)  = Prelude.LT;
       (_:_)  <=> []     = Prelude.GT;
       (x:xs) <=> (y:ys) = Eqtype.compare_op t x y Data.Monoid.<> xs <=> ys}
  in Eqtype.Equality__Mixin (eqseq t) (eqseqP t) (<=>)".

Extract Constant tuple.tuple_eqMixin => "\n t ->
  Eqtype.Equality__Mixin (\x y ->
    Eqtype.eq_op (Seq.seq_eqType t) (unsafeCoerce (tval n x))
      (unsafeCoerce (tval n y)))
    (unsafeCoerce
      (Eqtype.val_eqP (Seq.seq_eqType t) (\x ->
        Eqtype.eq_op Ssrnat.nat_eqType
          (unsafeCoerce (Seq.size (unsafeCoerce x))) (unsafeCoerce n))
        (unsafeCoerce (tuple_subType n))))
    (\x y ->
      Eqtype.compare_op
        (Seq.seq_eqType t)
        (unsafeCoerce (tval n x))
        (unsafeCoerce (tval n y)))".

Extract Constant atom_eqMixin => "\vEM tEM ->
  Eqtype.Equality__Mixin
    (atom_eqb  vEM tEM)
    (atom_eqbP vEM tEM)
    (\(v1 :@ t1) (v2 :@ t2) ->
        Eqtype.compare_op vEM v1 v2 Data.Monoid.<> Eqtype.compare_op tEM t1 t2)".

Extract Constant symbolic.Exports.state_eqMixin => "\mt p ->
  Eqtype.Equality__Mixin
    (_Exports__state_eqb  mt p)
    (_Exports__state_eqbP mt p)
    (_Exports__state_cmp  mt p)".

Extract Constant data_tag_eqMixin => "\mt ->
  Eqtype.Equality__Mixin
    (_Sym__Exports__data_tag_eq  mt)
    (_Sym__Exports__data_tag_eqP mt)
    (_Sym__Exports__data_tag_cmp mt)".

Extract Constant Sym.compartmentalization_internal_eqMixin => "\mt ->
  Eqtype.Equality__Mixin
    (_Sym__compartmentalization_internal_eqb  mt)
    (_Sym__compartmentalization_internal_eqbP mt)
    (_Sym__compartmentalization_internal_cmp  mt)".

Extract Constant concrete.Exports.state_eqMixin => "\mt ->
  Eqtype.Equality__Mixin
    (_Exports__state_eqb  mt)
    (_Exports__state_eqbP mt)
    (_Exports__state_cmp  mt)".

Extract Constant rules.mtag_eqMixin => "\tty ->
  let { (<=>) :: Coq_mtag -> Coq_mtag -> Prelude.Ordering
      ; User  u1 <=> User  u2 = Eqtype.compare_op (Symbolic._Symbolic__mem_tag_type   tty) u1 u2
      ; Entry e1 <=> Entry e2 = Eqtype.compare_op (Symbolic._Symbolic__entry_tag_type tty) e1 e2
      ; User  _  <=> Entry _  = Prelude.LT
      ; Entry _  <=> User  _  = Prelude.GT }
  in Data.Reflection.Constraint.providing (Data.Reflection.Constraint.Ord (<=>))
       (Eqtype.coq_CanEqMixin
         (Eqtype.sum_eqType
           (Symbolic._Symbolic__mem_tag_type tty)
           (Symbolic._Symbolic__entry_tag_type tty))
         (unsafeCoerce (sum_of_mtag tty))
         (unsafeCoerce (mtag_of_sum tty)))".

(* The following function, when extracted, fail to typecheck and I don't
   understand why -- or much care. *)
Extract Constant generic_quotient.enc_mod_rel =>
  "GHC.Stack.errorWithStackTrace ""enc_mod_rel: failed to compile with a type error""".

(* I've ignored most of the pure math stuff in MathComp (beyond what was
   necessary for the `eqType' change) -- we don't use it, and it's quite
   complicated.  This includes polynomials and matrices/linear algebra -- we
   certainly *could* use those things (they aren't super pure), but we don't,
   and there's plenty of extraction work already. *)

(* `concrete/exec.v'                  -> `exec.hs'
   `symbolic/exec.v'                  -> `exec0.hs'
   `concrete/int_32.v'                -> `int_32.hs'
   `symbolic/int_32.v'                -> `int_0.hs'
   `symbolic/symbolic.v'              -> `symbolic.hs'
   `compartmentalization/symbolic.hs' -> `symbolic0.hs' *)


Require Export Iron.Language.SystemF2Effect.Type.
Require Export Iron.Language.SystemF2Effect.Value.
Require Export Iron.Language.SystemF2Effect.Step.Pure.
Require Export Iron.Language.SystemF2Effect.Store.Prop.

(********************************************************************)
(* Frames *)
Inductive frame : Set :=
 (* Holds the continuation of a let-expression while the right
    of the binding is being evaluated. *)
 | FLet   : ty  -> exp      -> frame

 (* Private region.
    If the first argument is some region identifier then this new
    private region will be merged with that one when leaving its scope,
    otherwise the region is deallocated. *)
 | FPriv  : option nat -> nat -> frame.
Hint Constructors frame.

Definition isFPriv (p2 : nat) (f : frame)
 := exists p1, f = FPriv p1 p2.
Hint Unfold isFPriv.

(* Frame stacks *)
Definition stack := list frame.
Hint Unfold stack.

(********************************************************************)
(* Context sensitive reductions. *)
Inductive
 StepF :  store -> stprops -> stack -> exp
       -> store -> stprops -> stack -> exp
       -> Prop :=

 (* Pure evaluation *****************************)
 (* Pure evaluation in a context. *)
 | SfStep
   :  forall ss sp fs x x'
   ,  StepP           x           x'
   -> StepF  ss sp fs x  ss sp fs x'

 (* Let contexts ********************************)
 (* Push the continuation for a let-expression onto the stack. *)
 | SfLetPush
   :  forall ss sp fs t x1 x2
   ,  StepF  ss sp  fs               (XLet t x1 x2)
             ss sp (fs :> FLet t x2)  x1

 (* Substitute value of the bound variable into the let body. *)
 | SfLetPop
   :  forall ss sp  fs t v1 x2
   ,  StepF  ss sp (fs :> FLet t x2) (XVal v1)
             ss sp  fs               (substVX 0 v1 x2)

 (* Region operators ****************************)
 (* Create a private region. *)
 | SfPrivatePush
   :  forall ss sp fs x p
   ,  p = allocRegion sp
   -> StepF  ss sp                       fs                  (XPrivate x)
             ss (SRegion p <: sp)       (fs :> FPriv None p) (substTX 0 (TRgn p) x)

 (* Pop the frame for a private region and delete it from the heap. *)
 | SfPrivatePop
   :  forall ss sp  fs v1 p
   ,  StepF  ss                         sp (fs :> FPriv None p) (XVal v1)
             (map (deallocRegion p) ss) sp  fs                  (XVal v1)

 (* Begin extending an existing region. *)
 | SfExtendPush
   :  forall ss sp fs x p1 p2
   ,  p2 = allocRegion sp
   -> StepF ss sp                  fs                        (XExtend (TRgn p1) x)
            ss (SRegion p2 <: sp) (fs :> FPriv (Some p1) p2) (substTX 0 (TRgn p2) x)

 (* Pop the frame for a region extension and merge it with the existing one. *)
 | SfExtendPop
   :  forall ss sp fs p1 p2 v1
   ,  StepF  ss                      sp (fs :> FPriv (Some p1) p2) (XVal v1)
             (map (mergeB p1 p2) ss) sp fs                   (XVal (mergeV p1 p2 v1))

 (* Store operators *****************************)
 (* Allocate a reference. *)
 | SfStoreAlloc
   :  forall ss sp fs p1 v1
   ,  StepF  ss                    sp  fs (XAlloc (TRgn p1) v1)
             (StValue p1 v1 <: ss) sp  fs (XVal (VLoc (length ss)))

 (* Read from a reference. *)
 | SfStoreRead
   :  forall ss sp fs l v p
   ,  get l ss = Some (StValue p v)
   -> StepF ss                     sp  fs (XRead (TRgn p)  (VLoc l))
            ss                     sp  fs (XVal v)

 (* Write to a reference. *)
 | SfStoreWrite
   :  forall ss sp fs l p v1 v2
   ,  get l ss = Some (StValue p v1)
   -> StepF  ss sp fs                 (XWrite (TRgn p) (VLoc l) v2)
             (update l (StValue p v2) ss) sp fs (XVal (VConst CUnit)).

Hint Constructors StepF.

(********************************************************************)
Lemma stepF_extends_stprops
 :  forall  ss1 sp1 fs1 x1  ss2 sp2 fs2 x2
 ,  StepF   ss1 sp1 fs1 x1  ss2 sp2 fs2 x2
 -> extends sp2 sp1.
Proof.
 intros.
 induction H; eauto.
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.

(* Converted imports: *)

Require Data.Graph.Inductive.Graph.
Require Data.Graph.Inductive.Internal.Heap.
Require Data.Graph.Inductive.Internal.RootPath.
Require Err.
Require GHC.Base.
Require GHC.DeferredFix.
Require GHC.Err.
Require GHC.Num.
Require GHC.Real.
Import GHC.Base.Notations.
Import GHC.Num.Notations.

(* No type declarations to convert. *)

(* Midamble *)

Program Instance Dijkstra_Default {b} `{Err.Default b} : Err.Default (b * Data.Graph.Inductive.Graph.LPath b *
                                    Data.Graph.Inductive.Internal.Heap.Heap b (Data.Graph.Inductive.Graph.LPath b)).
Next Obligation.
destruct H. apply (default, Data.Graph.Inductive.Graph.LP nil, Data.Graph.Inductive.Internal.Heap.empty).
Defined.
(* Converted value declarations: *)

Definition expand {b} {a} `{(GHC.Real.Real b)}
   : b ->
     Data.Graph.Inductive.Graph.LPath b ->
     Data.Graph.Inductive.Graph.Context a b ->
     list (Data.Graph.Inductive.Internal.Heap.Heap b
           (Data.Graph.Inductive.Graph.LPath b)) :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | d, Data.Graph.Inductive.Graph.LP p, pair (pair (pair _ _) _) s =>
        GHC.Base.map (fun '(pair l v) =>
                        Data.Graph.Inductive.Internal.Heap.unit (l GHC.Num.+ d)
                        (Data.Graph.Inductive.Graph.LP (cons (pair v (l GHC.Num.+ d)) p))) s
    end.

Definition dijkstra {gr} {b} {a} `{Data.Graph.Inductive.Graph.Graph gr}
  `{GHC.Real.Real b} `{Err.Default b}
   : Data.Graph.Inductive.Internal.Heap.Heap b (Data.Graph.Inductive.Graph.LPath
                                              b) ->
     gr a b -> Data.Graph.Inductive.Internal.RootPath.LRTree b :=
  GHC.DeferredFix.deferredFix2 (fun dijkstra
                                (arg_0__
                                  : Data.Graph.Inductive.Internal.Heap.Heap b (Data.Graph.Inductive.Graph.LPath
                                                                             b))
                                (arg_1__ : gr a b) =>
                                  match arg_0__, arg_1__ with
                                  | h, g =>
                                      if orb (Data.Graph.Inductive.Internal.Heap.isEmpty h)
                                             (Data.Graph.Inductive.Graph.isEmpty g) : bool
                                      then nil else
                                      match arg_0__, arg_1__ with
                                      | h, g =>
                                          match Data.Graph.Inductive.Internal.Heap.splitMin h with
                                          | pair (pair _ (Data.Graph.Inductive.Graph.LP (cons (pair v d) _) as p)) h' =>
                                              match Data.Graph.Inductive.Graph.match_ v g with
                                              | pair (Some c) g' =>
                                                  cons p (dijkstra (Data.Graph.Inductive.Internal.Heap.mergeAll (cons h'
                                                                                (expand
                                                                                d
                                                                                p
                                                                                c)))
                                                        g')
                                              | pair None g' => dijkstra h' g'
                                              end
                                          | _ => GHC.Err.patternFailure
                                          end
                                      end
                                  end).

Definition spTree {gr} {b} {a} `{Data.Graph.Inductive.Graph.Graph gr}
  `{GHC.Real.Real b}
   : Data.Graph.Inductive.Graph.Node ->
     gr a b -> Data.Graph.Inductive.Internal.RootPath.LRTree b :=
  fun v =>
    dijkstra (Data.Graph.Inductive.Internal.Heap.unit #0
              (Data.Graph.Inductive.Graph.LP (cons (pair v #0) nil))).

Definition sp {gr} {b} {a} `{Data.Graph.Inductive.Graph.Graph gr}
  `{GHC.Real.Real b}
   : Data.Graph.Inductive.Graph.Node ->
     Data.Graph.Inductive.Graph.Node ->
     gr a b -> option Data.Graph.Inductive.Graph.Path :=
  fun s t g =>
    match Data.Graph.Inductive.Internal.RootPath.getLPathNodes t (spTree s g) with
    | nil => None
    | p => Some p
    end.

Definition spLength {gr} {b} {a} `{Data.Graph.Inductive.Graph.Graph gr}
  `{GHC.Real.Real b}
   : Data.Graph.Inductive.Graph.Node ->
     Data.Graph.Inductive.Graph.Node -> gr a b -> option b :=
  fun s t =>
    Data.Graph.Inductive.Internal.RootPath.getDistance t GHC.Base.∘ spTree s.

(* External variables:
     None Some bool cons list nil option orb pair Data.Graph.Inductive.Graph.Context
     Data.Graph.Inductive.Graph.Graph Data.Graph.Inductive.Graph.LP
     Data.Graph.Inductive.Graph.LPath Data.Graph.Inductive.Graph.Node
     Data.Graph.Inductive.Graph.Path Data.Graph.Inductive.Graph.isEmpty
     Data.Graph.Inductive.Graph.match_ Data.Graph.Inductive.Internal.Heap.Heap
     Data.Graph.Inductive.Internal.Heap.isEmpty
     Data.Graph.Inductive.Internal.Heap.mergeAll
     Data.Graph.Inductive.Internal.Heap.splitMin
     Data.Graph.Inductive.Internal.Heap.unit
     Data.Graph.Inductive.Internal.RootPath.LRTree
     Data.Graph.Inductive.Internal.RootPath.getDistance
     Data.Graph.Inductive.Internal.RootPath.getLPathNodes Err.Default GHC.Base.map
     GHC.Base.op_z2218U__ GHC.DeferredFix.deferredFix2 GHC.Err.patternFailure
     GHC.Num.fromInteger GHC.Num.op_zp__ GHC.Real.Real
*)


From Perennial.program_proof Require Import disk_prelude.

Section goose.
Context `{!heapGS Σ}.
Implicit Types v : val.
Implicit Types z : Z.
Implicit Types s : Slice.t.
Implicit Types (stk:stuckness) (E: coPset).

Definition is_block (s:Slice.t) (q: Qp) (b:Block) :=
  is_slice_small s byteT q (Block_to_vals b).

Definition is_block_full (s:Slice.t) (b:Block) :=
  is_slice s byteT 1 (Block_to_vals b).

Global Instance is_block_timeless s q b :
  Timeless (is_block s q b) := _.

Global Instance is_block_fractional s b :
  fractional.Fractional (λ q, is_block s q b).
Proof. apply is_slice_small_fractional. Qed.

Theorem is_block_not_nil s q b :
  is_block s q b -∗
  ⌜ s ≠ Slice.nil ⌝.
Proof.
  iIntros "Hb".
  rewrite /is_block.
  iDestruct (is_slice_small_not_null with "Hb") as "%Hnull"; eauto.
  { rewrite /Block_to_vals fmap_length.
    rewrite vec_to_list_length.
    rewrite /block_bytes. lia. }
  iPureIntro.
  destruct s. rewrite /Slice.nil. simpl in *. congruence.
Qed.

Definition list_to_block (l: list u8) : Block :=
  match decide (length l = Z.to_nat 4096) with
  | left H => eq_rect _ _ (list_to_vec l) _ H
  | _ => inhabitant
  end.

Lemma vec_to_list_to_vec_eq_rect A (l: list A) n (H: length l = n) :
  vec_to_list (eq_rect _ _ (list_to_vec l) _ H) = l.
Proof.
  rewrite <- H; simpl.
  rewrite vec_to_list_to_vec.
  auto.
Qed.

Theorem list_to_block_to_list l :
  length l = Z.to_nat 4096 ->
  vec_to_list (list_to_block l) = l.
Proof.
  intros H.
  rewrite /list_to_block /Block_to_vals.
  rewrite decide_True_pi.
  rewrite vec_to_list_to_vec_eq_rect; auto.
Qed.

Theorem list_to_block_to_vals l :
  length l = Z.to_nat 4096 ->
  Block_to_vals (list_to_block l) = b2val <$> l.
Proof.
  intros H.
  rewrite /Block_to_vals list_to_block_to_list //.
Qed.

Theorem block_list_inj l (b: Block) :
  l = vec_to_list b →
  b = list_to_block l.
Proof.
  intros ->.
  apply vec_to_list_inj2.
  rewrite list_to_block_to_list //.
  rewrite vec_to_list_length //.
Qed.

Theorem block_to_list_to_block i :
  list_to_block (vec_to_list i) = i.
Proof.
  symmetry.
  apply block_list_inj.
  auto.
Qed.

Lemma array_to_block l q (bs: list byte) :
  length bs = Z.to_nat 4096 ->
  l ↦∗[byteT]{q} (b2val <$> bs) -∗ mapsto_block l q (list_to_block bs).
Proof.
  rewrite /array /mapsto_block.
  iIntros (H) "Hl".
  rewrite -> list_to_block_to_vals by auto.
  rewrite heap_array_to_list.
  rewrite !big_sepL_fmap.
  setoid_rewrite Z.mul_1_l.
  iApply (big_sepL_impl with "Hl"); simpl.
  iModIntro.
  iIntros (i x) "% Hl".
  iApply (byte_mapsto_untype with "Hl").
Qed.

Lemma array_to_block_array l q b :
  array l q byteT (Block_to_vals b) ⊣⊢ mapsto_block l q b.
Proof.
  rewrite /mapsto_block /array.
  rewrite heap_array_to_list.
  rewrite ?big_sepL_fmap.
  setoid_rewrite Z.mul_1_l.
  apply big_opL_proper.
  intros k y Heq.
  rewrite /Block_to_vals in Heq.
  rewrite /b2val.
  rewrite byte_mapsto_untype //.
Qed.

Lemma slice_to_block_array s q b :
  is_slice_small s byteT q (Block_to_vals b) -∗ mapsto_block s.(Slice.ptr) q b.
Proof.
  rewrite /is_slice_small.
  iIntros "[Ha _]".
  by iApply array_to_block_array.
Qed.

Lemma block_array_to_slice_raw l q b :
  mapsto_block l q b -∗ l ↦∗[byteT]{q} Block_to_vals b ∗ ⌜length (Block_to_vals b) = int.nat 4096⌝.
Proof.
  iIntros "Hm".
  rewrite /is_slice_small.
  iSplitL.
  { iApply array_to_block_array. done. }
  iPureIntro.
  rewrite length_Block_to_vals.
  simpl. done.
Qed.

Transparent disk.Read disk.Write.

Ltac inv_undefined :=
  match goal with
  | [ H: relation.denote (match ?e with | _ => _ end) _ _ _ |- _ ] =>
    destruct e; try (apply suchThat_false in H; contradiction)
  end.

Local Ltac solve_atomic :=
  apply strongly_atomic_atomic, ectx_language_atomic;
  [ apply heap_head_atomic; cbn [relation.denote head_trans]; intros * H;
    repeat inv_undefined;
    try solve [ apply atomically_is_val in H; auto ]
    |apply ectxi_language_sub_redexes_are_values; intros [] **; naive_solver].

Theorem wp_Write_atomic (a: u64) s q b :
  ⊢ {{{ is_slice_small s byteT q (Block_to_vals b) }}}
  <<< ∀∀ b0, int.Z a d↦ b0 >>>
    Write #a (slice_val s) @ ∅
  <<< int.Z a d↦ b >>>
  {{{ RET #(); is_slice_small s byteT q (Block_to_vals b) }}}.
Proof.
  iIntros "!#" (Φ) "Hs Hupd".
  wp_call.
  wp_call.
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  iDestruct (is_slice_small_wf with "Hs") as %Hwf.
  iApply (wp_ncatomic _ _ ∅).
  { solve_atomic. inversion H. subst. monad_inv. inversion H0. subst. inversion H2. subst.
    inversion H4. subst. inversion H6. subst. inversion H7. econstructor. eauto. }
  rewrite difference_empty_L.
  iMod "Hupd" as (b0) "[Hda Hupd]"; iModIntro.
  wp_apply (wp_WriteOp with "[Hda Hs]").
  { iIntros "!>".
    iExists b0.
    iFrame.
    by iApply slice_to_block_array. }
  iIntros "[Hda Hmapsto]".
  iMod ("Hupd" with "Hda") as "HQ".
  iModIntro.
  iApply "HQ".
  rewrite /is_slice_small.
  iFrame.
  iSplitL; auto.
  by iApply array_to_block_array.
Qed.

Theorem wp_Write_triple E' (Q: iProp Σ) (a: u64) s q b :
  {{{ is_slice_small s byteT q (Block_to_vals b) ∗
      (|NC={⊤,E'}=> ∃ b0, int.Z a d↦ b0 ∗ (int.Z a d↦ b -∗ |NC={E',⊤}=> Q)) }}}
    Write #a (slice_val s)
  {{{ RET #(); is_slice_small s byteT q (Block_to_vals b) ∗ Q }}}.
Proof.
  iIntros (Φ) "[Hs Hupd] HΦ". iApply (wp_Write_atomic with "Hs").
  rewrite difference_empty_L. iNext.
  iMod "Hupd" as (b0) "[Hda Hclose]".
  iApply ncfupd_mask_intro; first set_solver+.
  iIntros "HcloseE". iExists b0.
  iFrame. iIntros "Hda". iMod "HcloseE" as "_". iMod ("Hclose" with "Hda").
  iIntros "!> Hs". iApply "HΦ". iFrame.
Qed.

Theorem wp_Write (a: u64) s q b :
  {{{ ∃ b0, int.Z a d↦ b0 ∗ is_slice_small s byteT q (Block_to_vals b) }}}
    Write #a (slice_val s)
  {{{ RET #(); int.Z a d↦ b ∗ is_slice_small s byteT q (Block_to_vals b) }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  iDestruct "Hpre" as (b0) "[Hda Hs]".
  wp_apply (wp_Write_atomic with "Hs").
  iApply ncfupd_mask_intro; first set_solver+.
  iIntros "Hclose". iExists _. iFrame.
  iIntros "Hda". iMod "Hclose" as "_".
  iIntros "!> Hs". iApply "HΦ". iFrame.
Qed.

Theorem wp_Write' (z: Z) (a: u64) s q b :
  {{{ ⌜int.Z a = z⌝ ∗ ▷ ∃ b0, z d↦ b0 ∗ is_slice_small s byteT q (Block_to_vals b) }}}
    Write #a (slice_val s)
  {{{ RET #(); z d↦ b ∗ is_slice_small s byteT q (Block_to_vals b) }}}.
Proof.
  iIntros (Φ) "[<- >Hpre] HΦ".
  iApply (wp_Write with "[$Hpre]").
  eauto.
Qed.

Lemma wp_Read_atomic (a: u64) q :
  ⊢ <<< ∀∀ b, int.Z a d↦{q} b >>>
      Read #a @ ∅
    <<< int.Z a d↦{q} b >>>
    {{{ s, RET slice_val s; is_block_full s b }}}.
Proof.
  iIntros "!#" (Φ) "Hupd".
  wp_call.
  wp_bind (ExternalOp _ _).
  rewrite difference_empty_L.
  iMod "Hupd" as (b) "[Hda Hupd]".
  { solve_atomic. inversion H. subst. monad_inv. inversion H0. subst. inversion H2. subst.
    inversion H4. subst. inversion H6. subst. inversion H7. econstructor. eauto. }
  wp_apply (wp_ReadOp with "Hda").
  iIntros (l) "(Hda&Hl)".
  iMod ("Hupd" with "Hda") as "HQ"; iModIntro.
  iDestruct (block_array_to_slice_raw with "Hl") as "Hs".
  wp_pures.
  wp_apply (wp_raw_slice with "Hs").
  iIntros (s) "Hs".
  iApply "HQ"; iFrame.
Qed.

Lemma wp_ReadTo_atomic (a: u64) b0 s q :
  ⊢ {{{ is_block_full s b0 }}}
  <<< ∀∀ b, int.Z a d↦{q} b >>>
      ReadTo #a (slice_val s) @ ∅
    <<< int.Z a d↦{q} b >>>
    {{{ RET #(); is_block_full s b }}}.
Proof.
  iIntros "!#" (Φ) "Hs Hupd".
  wp_call.
  iDestruct (is_slice_sz with "Hs") as %Hsz.
  iDestruct (is_slice_wf with "Hs") as %Hwf.
  wp_bind (ExternalOp _ _).
  iApply (wp_ncatomic _ _ ∅).
  { solve_atomic. inversion H. subst. monad_inv. inversion H0. subst. inversion H2. subst.
    inversion H4. subst. inversion H6. subst. inversion H7. econstructor. eauto. }
  rewrite difference_empty_L.
  iMod "Hupd" as (db0) "[Hda Hupd]"; iModIntro.
  wp_apply (wp_ReadOp with "[$Hda]").
  iIntros (l) "(Hda&Hl)".
  iMod ("Hupd" with "Hda") as "HQ".
  iModIntro.
  wp_pures.
  wp_apply wp_slice_ptr.
  iDestruct "Hs" as "[Hs Hcap]".
  rewrite /is_slice_small.
  iDestruct "Hs" as "[Hs _]".
  wp_apply (wp_MemCpy_rec with "[Hs Hl]").
  { iFrame.
    iDestruct (array_to_block_array with "Hl") as "$".
    iPureIntro.
    rewrite !length_Block_to_vals.
    rewrite /block_bytes.
    split; [ reflexivity | ].
    cbv; congruence.
  }
  rewrite take_ge; last first.
  { rewrite length_Block_to_vals.
    rewrite /block_bytes //. }
  iIntros "[Hs Hl]".
  iApply "HQ".
  rewrite /is_block_full /is_slice /is_slice_small.
  iFrame.
  iPureIntro.
  move: Hsz; rewrite !length_Block_to_vals //.
Qed.

Lemma wp_Read_triple E' (Q: Block -> iProp Σ) (a: u64) q :
  {{{ |NC={⊤,E'}=> ∃ b, int.Z a d↦{q} b ∗ (int.Z a d↦{q} b -∗ |NC={E',⊤}=> Q b) }}}
    Read #a
  {{{ s b, RET slice_val s;
      Q b ∗ is_block_full s b }}}.
Proof.
  iIntros (Φ) "Hupd HΦ". iApply wp_Read_atomic.
  rewrite difference_empty_L. iNext.
  iMod "Hupd" as (b0) "[Hda Hclose]".
  iApply ncfupd_mask_intro; first set_solver+.
  iIntros "HcloseE". iExists _. iFrame.
  iIntros "Hda". iMod "HcloseE" as "_". iMod ("Hclose" with "Hda").
  iIntros "!> * Hs". iApply "HΦ". iFrame.
Qed.

Lemma wp_Read (a: u64) q b :
  {{{ int.Z a d↦{q} b }}}
    Read #a
  {{{ s, RET slice_val s;
      int.Z a d↦{q} b ∗ is_block_full s b }}}.
Proof.
  iIntros (Φ) "Hda HΦ".
  wp_apply wp_Read_atomic.
  iApply ncfupd_mask_intro; first set_solver+.
  iIntros "HcloseE". iExists _. iFrame.
  iIntros "Hda". iMod "HcloseE" as "_".
  iIntros "!> * Hs". iApply ("HΦ" with "[$]").
Qed.

Lemma wp_Barrier stk E  :
  {{{ True }}}
    Barrier #() @ stk; E
  {{{ RET #(); True }}}.
Proof.
  iIntros (Φ) "_ HΦ".
  wp_call.
  iApply ("HΦ" with "[//]").
Qed.

Lemma wpc_Barrier stk E1 :
  {{{ True }}}
    Barrier #() @ stk; E1
  {{{ RET #(); True }}}
  {{{ True }}}.
Proof.
  iIntros (Φ Φc) "_ HΦ".
  rewrite /Barrier.
  wpc_pures; auto.
  - by crash_case.
  - iRight in "HΦ".
    iApply ("HΦ" with "[//]").
  - by crash_case.
Qed.

Lemma wpc_Read stk E1 (a: u64) q b :
  {{{ int.Z a d↦{q} b }}}
    Read #a @ stk; E1
  {{{ s, RET slice_val s;
      int.Z a d↦{q} b ∗
      is_slice s byteT 1%Qp (Block_to_vals b) }}}
  {{{ int.Z a d↦{q} b }}}.
Proof.
  iIntros (Φ Φc) "Hda HΦ".
  rewrite /Read.
  wpc_pures.
  { by crash_case. }
  wpc_bind (ExternalOp _ _).
  assert (Atomic StronglyAtomic (ExternalOp ReadOp #a)).
  {
    solve_atomic. inversion H. subst. monad_inv. inversion H0. subst. inversion H2. subst.
    inversion H4. subst. inversion H6. subst. inversion H7. econstructor. eauto.
  }
  wpc_atomic; iFrame.
  wp_apply (wp_ReadOp with "Hda").
  iIntros (l) "(Hda&Hl)".
  iDestruct (block_array_to_slice_raw with "Hl") as "Hs".
  iSplit.
  { iDestruct "HΦ" as "(HΦ&_)".
    iModIntro.
    iDestruct ("HΦ" with "[$]") as "H". repeat iModIntro; auto. }
  iModIntro. wpc_pures; first by crash_case.
  wpc_frame "Hda HΦ".
  { by crash_case. }
  wp_apply (wp_raw_slice with "Hs").
  iIntros (s) "Hs".
  iIntros "(?&HΦ)". iApply "HΦ".
  iFrame.
Qed.

Theorem wpc_Write_ncfupd {stk E1} E1' (a: u64) s q b :
  ∀ Φ Φc,
    is_block s q b -∗
    (Φc ∧ |NC={E1,E1'}=> ∃ b0, int.Z a d↦ b0 ∗ ▷ (int.Z a d↦ b -∗ |NC={E1',E1}=>
          Φc ∧ (is_block s q b -∗ Φ #()))) -∗
    WPC Write #a (slice_val s) @ stk; E1 {{ Φ }} {{ Φc }}.
Proof.
  iIntros (Φ Φc) "Hs Hfupd".
  rewrite /Write /slice.ptr.
  wpc_pures.
  { iLeft in "Hfupd". iFrame. }
  iDestruct (is_slice_small_sz with "Hs") as %Hsz.
  iDestruct (is_slice_small_wf with "Hs") as %Hwf.
  assert (Atomic StronglyAtomic (ExternalOp WriteOp (#a, #s.(Slice.ptr))%V)).
  {
    solve_atomic. inversion H. subst. monad_inv. inversion H0. subst. inversion H2. subst.
    inversion H4. subst. inversion H6. subst. inversion H7. econstructor. eauto.
  }
  wpc_atomic.
  iRight in "Hfupd".
  iMod "Hfupd" as (b0) "[Hda HQ]".
  wp_apply (wp_WriteOp with "[Hda Hs]").
  { iIntros "!>".
    iExists b0; iFrame.
    by iApply slice_to_block_array. }
  iIntros "[Hda Hmapsto]".
  iMod ("HQ" with "Hda") as "HQ".
  iModIntro.
  iSplit.
  - iDestruct "HQ" as "(HQ&_)". iModIntro. by repeat iModIntro.
  - iModIntro. iRight in "HQ". iApply "HQ".
    iFrame.
    destruct s; simpl in Hsz.
    replace sz with (U64 4096).
    + iDestruct (block_array_to_slice_raw with "Hmapsto") as "[? %]".
      rewrite /is_block /is_slice_small. iFrame.
      iPureIntro. simpl. split; first done. simpl in Hwf. word.
    + rewrite length_Block_to_vals in Hsz.
      change block_bytes with (Z.to_nat 4096) in Hsz.
      word.
Qed.

(* This is a TaDA-syle logically atomic spec, so the HoCAP-style sugar does not work. *)
Theorem wpc_Write_fupd {stk E1} E1' (a: u64) s q b :
  ∀ Φ Φc,
    is_block s q b -∗
    (Φc ∧ |={E1,E1'}=> ∃ b0, int.Z a d↦ b0 ∗ ▷ (int.Z a d↦ b ={E1',E1}=∗
          Φc ∧ (is_block s q b -∗ Φ #()))) -∗
    WPC Write #a (slice_val s) @ stk; E1 {{ Φ }} {{ Φc }}.
Proof.
  iIntros (??) "Hblock HΦc".
  wpc_apply (wpc_Write_ncfupd with "[$]").
  iSplit.
  - by iLeft in "HΦc".
  - iRight in "HΦc". iApply fupd_ncfupd. iMod "HΦc" as (?) "(?&H1)".
    iModIntro. iExists _. iFrame. iNext. iIntros "H2".
      by iMod ("H1" with "[$]").
Qed.

Theorem wpc_Write_fupd_triple {stk E1} E1' (Q Qc: iProp Σ) (a: u64) s q b :
  {{{ is_block s q b ∗
      (Qc ∧ |={E1,E1'}=> ∃ b0, int.Z a d↦ b0 ∗ ▷ (int.Z a d↦ b ={E1',E1}=∗ Qc ∧ Q)) }}}
    Write #a (slice_val s) @ stk; E1
  {{{ RET #(); is_block s q b ∗ Qc ∧ Q }}}
  {{{ Qc }}}.
Proof.
  iIntros (Φ Φc) "Hpre HΦ".
  iDestruct "Hpre" as "[Hs Hfupd]".
  iApply (wpc_Write_fupd with "Hs"). iSplit.
  { iLeft in "Hfupd". iLeft in "HΦ". iApply "HΦ". iFrame. }
  iRight in "Hfupd". iMod "Hfupd" as (b0) "[Hv Hclose]". iModIntro.
  iExists b0. iFrame. iIntros "!> Hv". iMod ("Hclose" with "Hv") as "HQ".
  iModIntro. iSplit.
  { iLeft in "HΦ". iLeft in "HQ". iApply "HΦ". iFrame. }
  iRight in "HΦ". iIntros "Hblock". iApply "HΦ". iFrame.
Qed.

Theorem wpc_Write' stk E1 (a: u64) s q b0 b :
  {{{ int.Z a d↦ b0 ∗ is_block s q b }}}
    Write #a (slice_val s) @ stk; E1
  {{{ RET #(); int.Z a d↦ b ∗ is_block s q b }}}
  {{{ (int.Z a d↦ b0 ∨ int.Z a d↦ b) }}}.
Proof.
  iIntros (Φ Φc) "Hpre HΦ".
  iDestruct "Hpre" as "[Hda Hs]".
  wpc_apply (wpc_Write_fupd with "[$Hs]").
  iSplit.
  { crash_case.
    eauto. }
  iModIntro.
  iExists _; iFrame.
  iIntros "!> Hda !>".
  iSplit.
  { crash_case; eauto. }
  iRight in "HΦ".
  iIntros "Hb".
  iApply "HΦ"; iFrame.
Qed.

Theorem wpc_Write stk E1 (a: u64) s q b :
  {{{ ∃ b0, int.Z a d↦ b0 ∗ is_block s q b }}}
    Write #a (slice_val s) @ stk; E1
  {{{ RET #(); int.Z a d↦ b ∗ is_block s q b }}}
  {{{ ∃ b', int.Z a d↦ b' }}}.
Proof.
  iIntros (Φ Φc) "Hpre HΦ".
  iDestruct "Hpre" as (b0) "[Hda Hs]".
  wpc_apply (wpc_Write' with "[$Hda $Hs]").
  iSplit.
  { iLeft in "HΦ". iIntros "[Hda|Hda]"; iApply "HΦ"; eauto. }
  iIntros "!> [Hda Hb]".
  iRight in "HΦ".
  iApply "HΦ"; iFrame.
Qed.

Theorem slice_to_block s q bs :
  s.(Slice.sz) = 4096 ->
  is_slice_small s byteT q (b2val <$> bs) -∗
  mapsto_block s.(Slice.ptr) q (list_to_block bs).
Proof.
  iIntros (Hsz) "Hs".
  rewrite /is_slice_small.
  iDestruct "Hs" as "[Hl %]".
  rewrite fmap_length in H.
  iApply (array_to_block with "Hl").
  assert (int.Z (Slice.sz s) = 4096).
  { rewrite Hsz. reflexivity. }
  lia.
Qed.

End goose.


(** * MOV instruction *)
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import spec SPred septac spec safe triple basic basicprog spectac.
Require Import instr instrcodec eval monad monadinst reader pointsto cursor.
Require Import Setoid RelationClasses Morphisms.

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

Require Import Relations.
Require Import instrsyntax.

Local Open Scope instr_scope.

Require Import x86.instrrules.core.

(** ** Generic rule *)
Lemma MOV_rule d ds oldv:
  |-- specAtDstSrc ds (fun V v =>
      basic (V oldv) (MOVOP d ds) (V v)).
Proof. do_instrrule_triple. Qed.

Ltac basicMOV :=
  rewrite /makeMOV;
  let R := lazymatch goal with
             | |- |-- basic ?p (@MOVOP ?d ?a) ?q => constr:(@MOV_rule d a)
           end in
  basicapply R.

(** We open a section in order to localize the hints *)
Section InstrRules.

Hint Unfold
  specAtDstSrc specAtSrc specAtRegMemDst specAtMemSpec specAtMemSpecDst
  DWORDRegMemR BYTERegMemR DWORDRegMemM DWORDRegImmI fromSingletonMemSpec
  DWORDorBYTEregIs natAsDWORD BYTEtoDWORD
  makeMOV makeBOP makeUOP
  : basicapply.
Hint Rewrite
  addB0 low_catB : basicapply.

(** ** Register to register *)
Lemma MOV_RR_rule (r1 r2:Reg) v1 v2:
  |-- basic (r1 ~= v1 ** r2 ~= v2) (MOV r1, r2) (r1 ~= v2 ** r2 ~= v2).
Proof. basicMOV. Qed.

Lemma MOV_RanyR_rule (r1 r2:Reg) v2:
  |-- basic (r1? ** r2 ~= v2) (MOV r1, r2) (r1 ~= v2 ** r2 ~= v2).
Proof. unhideReg r1 => old. basicMOV. Qed.

(** ** Immediate to register *)
Lemma MOV_RI_rule (r:Reg) (v1 v2:DWORD) :
  |-- basic (r ~= v1) (MOV r, v2) (r ~= v2).
Proof. basicMOV. Qed.

Lemma MOV_RanyI_rule (r:Reg) (v2:DWORD) :
  |-- basic r? (MOV r, v2) (r ~= v2).
Proof. unhideReg r => old. basicMOV. Qed.

(** ** Memory to register *)
Lemma MOV_RM_rule (pd:DWORD) (r1 r2:Reg) offset (v1 v2: DWORD) :
  |-- basic (r1 ~= v1 ** r2 ~= pd ** pd +# offset :-> v2)
            (MOV r1, [r2 + offset])
            (r1 ~= v2 ** r2 ~= pd ** pd +# offset :-> v2).
Proof. basicMOV. Qed.

Lemma MOV_RanyM_rule (pd:DWORD) (r1 r2:Reg) offset (v2: DWORD) :
  |-- basic (r1? ** r2 ~= pd ** pd +# offset :-> v2)
            (MOV r1, [r2 + offset])
            (r1 ~= v2 ** r2 ~= pd ** pd +# offset :-> v2).
Proof. unhideReg r1 => old. basicMOV. Qed.

Lemma MOV_RM0_rule (pd:DWORD) (r1 r2:Reg) (v1 v2: DWORD) :
  |-- basic (r1 ~= v1 ** r2 ~= pd ** pd :-> v2)
            (MOV r1, [r2])
            (r1 ~= v2 ** r2 ~= pd ** pd :-> v2).
Proof. basicMOV. Qed.

Lemma MOV_RanyM0_rule (pd:DWORD) (r1 r2:Reg) (v2: DWORD) :
  |-- basic (r1? ** r2 ~= pd ** pd :-> v2)
            (MOV r1, [r2])
            (r1 ~= v2 ** r2 ~= pd ** pd :-> v2).
Proof. unhideReg r1 => old. basicMOV. Qed.

(** ** Register to memory *)
Lemma MOV_MR_rule (p: DWORD) (r1 r2: Reg) offset (v1 v2:DWORD) :
  |-- basic (r1~=p ** p +# offset :-> v1 ** r2~=v2)
            (MOV [r1 + offset], r2)
            (r1~=p ** p +# offset :-> v2 ** r2~=v2).
Proof. basicMOV. Qed.

(** ** Immediate to memory *)
Lemma MOV_MI_rule dword (pd:DWORD) (r:Reg) offset (v w:DWORDorBYTE dword) :
  |-- basic (r ~= pd ** pd +# offset :-> v)
            (MOVOP _ (DstSrcMI dword (mkMemSpec (Some(r, None)) #offset) w))
            (r ~= pd ** pd +# offset :-> w).
Proof. basicMOV. Qed.

Lemma MOV_M0R_rule (pd:DWORD) (r1 r2:Reg) (v1 v2: DWORD) :
  |-- basic (r1 ~= pd ** pd :-> v1 ** r2 ~= v2)
            (MOV [r1], r2)
            (r1 ~= pd ** pd :-> v2 ** r2 ~= v2).
Proof. basicMOV. Qed.

Lemma MOV_MbR_rule (p: DWORD) (r1:Reg) (r2: BYTEReg) offset (v1:BYTE) (v2:BYTE) :
  |-- basic (r1 ~= p ** p +# offset :-> v1 ** BYTEregIs r2 v2)
            (MOV [r1 + offset], r2)
            (r1 ~= p ** p +# offset :-> v2 ** BYTEregIs r2 v2).
Proof. basicMOV. Qed.

Lemma MOV_MbR_ruleGen d (p: DWORD) (r1:Reg) (r2: DWORDorBYTEReg d) offset (v1 v2:DWORDorBYTE d):
  |-- basic (r1 ~= p ** p +# offset :-> v1 ** DWORDorBYTEregIs r2 v2)
            (MOVOP d (DstSrcMR d (mkMemSpec (Some(r1,None)) #offset) r2))
            (r1 ~= p ** p +# offset :-> v2 ** DWORDorBYTEregIs r2 v2).
Proof.
  destruct d.
  { apply MOV_MR_rule. }
  { apply MOV_MbR_rule. }
Qed.

Lemma MOV_RMb_rule (p: DWORD) (r1:Reg) (r2:BYTEReg) offset (v1:BYTE) (v2:BYTE) :
  |-- basic (r1 ~= p ** p +# offset :-> v1 ** BYTEregIs r2 v2)
            (MOV r2, [r1 + offset])
            (r1 ~= p ** p +# offset :-> v1 ** BYTEregIs r2 v1).
Proof. basicMOV. Qed.

Lemma MOV_MbI_rule (pd:DWORD) (r1:Reg) offset (v1 v2:BYTE) :
  |-- basic (r1 ~= pd ** pd +# offset :-> v1)
            (MOV BYTE [r1 + offset], v2)
            (r1 ~= pd ** pd +# offset :-> v2).
Proof. basicMOV. Qed.
End InstrRules.