(*===========================================================================
  Basic representation of n-bit words

  We use n.-tuples of bools, as this gives decidable equality and finiteness
  for free.

  Tuples are practical for evaluation inside Coq, and so all operations on
  words can be evaluated using compute, cbv, etc.

  Proofs of various properties of bitvectors can be found in bitsprops.v
  Definitions of operations on bitvectors can be found in bitsops.v
  Proofs of properties of operations can be found in bitsopsprops.v
  ===========================================================================*)

From Coq Require Import ZArith.ZArith Strings.String.

Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq fintype tuple zmodp.

(* We represent n-bit words by a tuple of booleans.
 LSB is the leftmost bit or the head of the tuple.
 For example number 8 as an EVMWORD is the tuple:
 0001 0000 ... 0000 - 32 bytes *)

Definition BITS n := n.-tuple bool.

(** We define aliases for various numbers, to speed up proofs.  We use
 [.+1] to ensure convertibility after adding or subtracting 1. *)

Definition n3 := 3.
Definition n7 := 7.
Definition n15 := 15.
Definition n31 := 31.
Definition n63 := 63.
Definition n127 := 127.
Definition n159 := 159.
Definition n255 := 255.

Arguments n3 : simpl never.
Arguments n7 : simpl never.
Arguments n15 : simpl never.
Arguments n31 : simpl never.
Arguments n63 : simpl never.
Arguments n127 : simpl never.
Arguments n159 : simpl never.
Arguments n255 : simpl never.
Opaque n3 n7 n15 n31 n63 n127 n159 n255.

Notation n4 := n3.+1.
Notation n8 := n7.+1.
Notation n16 := n15.+1.
Notation n32 := n31.+1.
Notation n64 := n63.+1.
Notation n128 := n127.+1.
Notation n160 := n159.+1.
Notation n256 := n255.+1.

Definition n24 := 24.
Arguments n24 : simpl never.
Opaque n24.
Definition NIBBLE := BITS n4.

(* Range of word sizes that we support for the stack, memory, and storage *)
Inductive OpSize :=
 OpSize1 (* 8-bits *)
|OpSize2
|OpSize4
|OpSize8
|OpSize16
|OpSize20
|OpSize32.

(* OpSize to nat *)
Definition opSizeToNat (s : OpSize) : nat :=
match s with
|OpSize1 => 1
|OpSize2 => 2
|OpSize4 => 4
|OpSize8 => 8
|OpSize16 => 16
|OpSize20 => 20
|OpSize32 => 32
end.

Definition VWORD s :=
BITS
(match s with
 OpSize1 => n8
|OpSize2 => n16
|OpSize4 => n32
|OpSize8 => n64
|OpSize16 => n128
|OpSize20 => n160
|OpSize32 => n256 end).

Definition BYTE := (VWORD OpSize1).

Definition WORD := (VWORD OpSize2).

Definition DWORD := (VWORD OpSize4).

Definition QWORD := (VWORD OpSize8).

Definition DQWORD := (VWORD OpSize16).

Definition ADDRESS := (VWORD OpSize20).

Definition EVMWORD := (VWORD OpSize32).

Identity Coercion VWORDtoBITS : VWORD >-> BITS.
Identity Coercion BYTEtoVWORD : BYTE >-> VWORD.
Identity Coercion WORDtoVWORD : WORD >-> VWORD.
Identity Coercion DWORDtoVWORD : DWORD >-> VWORD.
Identity Coercion QWORDtoVWORD : QWORD >-> VWORD.
Identity Coercion DQWORDtoVWORD : DQWORD >-> VWORD.
Identity Coercion ADDRESStoVWORD : ADDRESS >-> VWORD.
Identity Coercion EVMWORDtoVWORD : EVMWORD >-> VWORD.

(*-----------------------------------------------------------------------
 Constructors
 -----------------------------------------------------------------------*)
Notation "'nilB'" := (nil_tuple _).

(* Concate 1 bit as LSB one *)
Definition consB {n} (b : bool) (p : BITS n) : BITS n.+1 :=
  cons_tuple b p.

Definition joinlsb {n} (pair : BITS n * bool) : BITS n.+1 :=
  cons_tuple pair.2 pair.1.

(*------------------------------------------------------------------------
  Destructors
 ------------------------------------------------------------------------*)
Definition splitlsb {n} (p : BITS n.+1) : BITS n * bool :=
  (behead_tuple p, thead p).

Definition droplsb {n} (p : BITS n.+1) : BITS n :=
  (splitlsb p).1.

(*------------------------------------------------------------------------
 Conversion to and from nat numbers.
 ------------------------------------------------------------------------*)
Fixpoint fromNat {n} m : BITS n :=
  if n is _.+1 then
    joinlsb (fromNat m./2, odd m)
  else nilB.

Notation "# m" := (fromNat m) (at level 0).

Arguments fromNat n m : simpl never.

Definition toNat {n} (p : BITS n) :=
  foldr (fun (b : bool) n => b + n.*2) 0 p.

Coercion natAsEVMWORD := @fromNat _ : nat -> EVMWORD.
Coercion natAsADDRESS := @fromNat _ : nat -> ADDRESS.
Coercion natAsDQWORD := @fromNat _ : nat -> DQWORD.
Coercion natAsQWORD := @fromNat _ : nat -> QWORD.
Coercion natAsDWORD := @fromNat _ : nat -> DWORD.
Coercion natAsWORD := @fromNat _ : nat -> WORD.
Coercion natAsBYTE := @fromNat _ : nat -> BYTE.

(* All bits identical *)
Definition copy n b : BITS n :=
  nseq_tuple n b.

Definition zero n := copy n false.

Definition ones n := copy n true.

(*---------------------------------------------------------------------------
 Concatenation and splitting of bit strings
 --------------------------------------------------------------------------*)

(* Most and least significant bits, defaulting to 0 *)
Definition msb {n} (b: BITS n) := last false b.
Definition lsb {n} (b: BITS n) := head false b.

(* p2 is least-significant part *)
Definition catB {n1 n2} (p1: BITS n1) (p2: BITS n2) : BITS (n2+n1) :=
  cat_tuple p2 p1.
Notation "y ## x" := (catB y x) (right associativity, at level 60).

(* The n high bits *)
Fixpoint high n {n2} : BITS (n2+n) -> BITS n :=
  if n2 is _.+1 then fun p => let (p,b) := splitlsb p in high _ p else fun p => p.

(* The n low bits *)
Fixpoint low {n1} n : BITS (n+n1) -> BITS n :=
  if n is _.+1 then
    fun p => let (p,b) := splitlsb p in joinlsb (low _ p, b)
  else fun p => nilB.

(* n1 high and n2 low bits *)
Definition split2 n1 n2 p := (high n1 p, low n2 p).

Definition split3 n1 n2 n3 (p: BITS (n3+n2+n1)) : BITS n1 * BITS n2 * BITS n3 :=
  let (hi,lo) := split2 n1 _ p in
  let (lohi,lolo) := split2 n2 _ lo in (hi,lohi,lolo).

Definition split4 n1 n2 n3 n4 (p: BITS (n4+n3+n2+n1)): BITS n1 * BITS n2 * BITS n3 * BITS n4 :=
  let (b1,rest) := split2 n1 _ p in
  let (b2,rest) := split2 n2 _ rest in
  let (b3,b4)   := split2 n3 _ rest in (b1,b2,b3,b4).

Definition split8 n1 n2 n3 n4 n5 n6 n7 n8 (p: BITS (n8+n7+n6+n5+n4+n3+n2+n1)): BITS n1 * BITS n2 * BITS n3 * BITS n4 * BITS n5 * BITS n6 * BITS n7 * BITS n8 :=
  let '(b1,b2,b3,rest) := split4 n1 n2 n3 _ p in
  let '(b4,b5,b6,rest) := split4 n4 n5 n6 _ rest in
  let '(b7,b8) := split2 n7 n8 rest in (b1,b2,b3,b4,b5,b6,b7,b8).

Definition split16 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 (p: BITS (n16+n15+n14+n13+n12+n11+n10+n9+n8+n7+n6+n5+n4+n3+n2+n1)):
BITS n1 * BITS n2 * BITS n3 * BITS n4 * BITS n5 * BITS n6 * BITS n7 * BITS n8 * BITS n9 * BITS n10 * BITS n11 * BITS n12 * BITS n13 * BITS n14 * BITS n15 * BITS n16 :=
  let '(b1,b2,b3,b4,b5,b6,b7,rest) := split8 n1 n2 n3 n4 n5 n6 n7 _ p in
  let '(b8,b9,b10,b11,b12,b13,b14,rest) := split8 n8 n9 n10 n11 n12 n13 n14 _ rest in
  let '(b15,b16) := split2 n15 n16 rest in (b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,b16).

Definition split20 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 (p: BITS (n20+n19+n18+n17+n16+n15+n14+n13+n12+n11+n10+n9+n8+n7+n6+n5+n4+n3+n2+n1)):
BITS n1 * BITS n2 * BITS n3 * BITS n4 * BITS n5 * BITS n6 * BITS n7 * BITS n8 * BITS n9 * BITS n10 * BITS n11 * BITS n12 * BITS n13 * BITS n14 * BITS n15 * BITS n16 * BITS n17 * BITS n18 * BITS n19 * BITS n20 :=
  let '(b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,rest) := split16 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 _ p in
  let '(b16,b17,b18,rest) := split4 n16 n17 n18 _ rest in
  let '(b19,b20) := split2 n19 n20 rest in (b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,b16,b17,b18,b19,b20).

Definition split32 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 n31 n32
(p: BITS (n32+n31+n30+n29+n28+n27+n26+n25+n24+n23+n22+n21+n20+n19+n18+n17+n16+n15+n14+n13+n12+n11+n10+n9+n8+n7+n6+n5+n4+n3+n2+n1)):
BITS n1 * BITS n2 * BITS n3 * BITS n4 * BITS n5 * BITS n6 * BITS n7 * BITS n8 * BITS n9 * BITS n10 * BITS n11 * BITS n12 * BITS n13 * BITS n14 * BITS n15 * BITS n16 * BITS n17 * BITS n18 * BITS n19 * BITS n20 *
BITS n21 * BITS n22 * BITS n23 * BITS n24 * BITS n25 * BITS n26 * BITS n27 * BITS n28 * BITS n29 * BITS n30 * BITS n31 * BITS n32 :=
  let '(b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,rest) := split16 n1 n2 n3 n4 n5 n6 n7 n8 n9 n10 n11 n12 n13 n14 n15 _ p in
  let '(b16,b17,b18,b19,b20,b21,b22,b23,b24,b25,b26,b27,b28,b29,b30,rest) := split16 n16 n17 n18 n19 n20 n21 n22 n23 n24 n25 n26 n27 n28 n29 n30 _ rest in
  let '(b31,b32) := split2 n31 n32 rest in (b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14,b15,b16,b17,b18,b19,b20,b21,b22,b23,b24,b25,b26,b27,b28,b29,b30,b31,b32).

(* Sign extend by {extra} bits *)
Definition signExtend extra {n} (p: BITS n.+1) := copy extra (msb p) ## p.

(* Truncate a signed integer by {extra} bits; return None if this would overflow *)
Definition signTruncate extra {n} (p: BITS (n.+1 + extra)) : option (BITS n.+1) :=
  let (hi,lo) := split2 extra _ p in
  if msb lo && (hi == ones _) || negb (msb lo) && (hi == zero _) then
    Some lo
  else None.

(* Zero extend by {extra} bits *)
Definition zeroExtend extra {n} (p : BITS n) := zero extra ## p.

Coercion BYTEtoDWORD := zeroExtend (n:=8) 24 : BYTE -> DWORD.
Coercion WORDtoDWORD := zeroExtend (n:=16) 16 : WORD -> DWORD.

Coercion BYTEtoEVMWORD := zeroExtend (n:=8) 248 : BYTE -> EVMWORD.
Coercion WORDtoEVMWORD := zeroExtend (n:=16) 240 : WORD -> EVMWORD.
Coercion DWORDtoEVMWORD := zeroExtend (n:=32) 224 : DWORD -> EVMWORD.
Coercion QWORDtoEVMWORD := zeroExtend (n:=64) 192 : QWORD -> EVMWORD.
Coercion DQWORDtoEVMWORD := zeroExtend (n:=128) 128 : DQWORD -> EVMWORD.
Coercion ADDRESStoEVMWORD := zeroExtend (n:=160) 96 : ADDRESS -> EVMWORD.

(* Take m least significant bits of n-bit argument and fill with zeros if m>n *)
Fixpoint lowWithZeroExtend m {n} : BITS n -> BITS m :=
  if n is _.+1 then
    fun p => let (p,b) := splitlsb p in
             if m is m'.+1 then joinlsb (@lowWithZeroExtend m' _ p, b)
             else zero 0
  else fun p => zero m.

(* BITS n to EVMWORD and fill with zeros if n < 256 *)
Definition lowWithZeroExtendToEVMWORD {n} (p : BITS n) : EVMWORD :=
  lowWithZeroExtend 256 p.

(* BITS n to BYTE and fill with zeros if n < 8 *)
Definition lowWithZeroExtendToBYTE {n} (p : BITS n) : BYTE :=
  lowWithZeroExtend 8 p.

(* Truncate an unsigned integer by {extra} bits; return None if this would overflow *)
Definition zeroTruncate extra {n} (p: BITS (n + extra)) : option (BITS n) :=
  let (hi,lo) := split2 extra _ p in
  if hi == zero _ then Some lo else None.

(* Special case: split at the most significant bit.
   split 1 n doesn't work because it requires BITS (n+1) not BITS n.+1 *)
Fixpoint splitmsb {n} : BITS n.+1 -> bool * BITS n :=
  if n is _.+1
  then fun p => let (p,b) := splitlsb p in let (c,r) := splitmsb p in (c,joinlsb(r,b))
  else fun p => let (p,b) := splitlsb p in (b,p).
Definition dropmsb {n} (p: BITS n.+1) := (splitmsb p).2.

(* Extend by one bit at the most significant bit. Again, signExtend 1 n does not work
   because BITS (n+1) is not definitionally equal to BITS n.+1  *)
Fixpoint joinmsb {n} : bool * BITS n -> BITS n.+1 :=
  if n is _.+1
  then fun p => let (hibit, p) := p in
                let (p,b) := splitlsb p in joinlsb (joinmsb (hibit, p), b)
  else fun p => joinlsb (nilB, p.1).
Definition joinmsb0 {n} (p: BITS n) : BITS n.+1 := joinmsb (false,p).

Fixpoint zeroExtendAux extra {n} (p: BITS n) : BITS (extra+n) :=
  if extra is e.+1 then joinmsb0 (zeroExtendAux e p) else p.

Definition joinNibble {n}  (p:NIBBLE) (q: BITS n) : BITS (n.+4) :=
  let (p1,b0) := splitlsb p in
  let (p2,b1) := splitlsb p1 in
  let (p3,b2) := splitlsb p2 in
  let (p4,b3) := splitlsb p3 in
   joinmsb (b3, joinmsb (b2, joinmsb (b1, joinmsb (b0, q)))).

Notation "y ## x" := (catB y x) (right associativity, at level 60).

(* Slice of bits *)
Definition slice n n1 n2 (p: BITS (n+n1+n2)) : BITS n1 :=
  let: (a,b,c) := split3 n2 n1 n p in b.

Definition updateSlice n n1 n2 (p: BITS (n+n1+n2)) (m:BITS n1) : BITS (n+n1+n2) :=
  let: (a,b,c) := split3 n2 n1 n p in a ## m ## c.

(* Join BYTE to BITS n *)
Definition joinBYTE {n} (pair : BITS n * BYTE) : BITS (n8+n) :=
  cat_tuple pair.2 pair.1.

(* From tuple of BYTEs to BITS n, preserve the order in b or the head is the least-significant byte *)
Fixpoint fromBytes (b : seq BYTE) : BITS (size b * 8) :=
  match b with
    | nil => #0
    | h::t => joinBYTE ((fromBytes t), h)
  end.

(*---------------------------------------------------------------------------
    Single bit operations
 ---------------------------------------------------------------------------*)

(* Booleans are implicitly coerced to one-bit words, useful in combination with ## *)
Coercion singleBit b : BITS 1 := joinlsb (nilB, b).

(* Get bit i, counting 0 as least significant *)
(* For some reason tnth is not efficiently computable, so we use nth *)
Definition getBit {n} (p: BITS n) (i:nat) := nth false p i.

(* Set bit i to b *)
Fixpoint setBitAux {n} i b : BITS n -> BITS n :=
  if n is _.+1
  then fun p => let (p,oldb) := splitlsb p in
                if i is i'.+1 then joinlsb (setBitAux i' b p, oldb) else joinlsb (p,b)
  else fun p => nilB.

Definition setBit {n} (p: BITS n) i b := setBitAux i b p.

(*---------------------------------------------------------------------------
    Efficient conversion to and from Z
 ---------------------------------------------------------------------------*)

Definition toPosZ {n} (p: BITS n) :=
  foldr (fun b z => if b then Zsucc (Zdouble z) else Zdouble z) Z0 p.

Definition toNegZ {n} (p: BITS n) :=
  foldr (fun b z => if b then Zdouble z else Zsucc (Zdouble z)) Z0 p.

Definition toZ {n} (bs: BITS n.+1) :=
  match splitmsb bs with
  | (false, bs') => toPosZ bs'
  | (true, bs') => Zopp (Zsucc (toNegZ bs'))
  end.

Fixpoint fromPosZ {n} (z: Z): BITS n :=
  if n is _.+1
  then joinlsb (fromPosZ (Zdiv2 z), negb (Zeven_bool z))
  else nilB.

Fixpoint fromNegZ {n} (z: Z): BITS n :=
  if n is _.+1
  then joinlsb (fromNegZ (Zdiv2 z), Zeven_bool z)
  else nilB.

Definition fromZ {n} (z:Z) : BITS n :=
  match z with
  | Zpos _ => fromPosZ z
  | Zneg _ => fromNegZ (Zpred (Zopp z))
  | _ => zero _
  end.

(*---------------------------------------------------------------------------
    Conversion to and from 'Z_(2^n)
 ---------------------------------------------------------------------------*)

Definition toZp {n} (p: BITS n) : 'Z_(2^n) := inZp (toNat p).
Definition fromZp {n} (z: 'Z_(2^n)) : BITS n := fromNat z.

Definition bool_inZp m (b:bool): 'Z_m := inZp b.
Definition toZpAux {m n} (p:BITS n) : 'Z_(2^m) := inZp (toNat p).

(*---------------------------------------------------------------------------
    Support for hexadecimal notation
 ---------------------------------------------------------------------------*)
Section HexStrings.
Import Ascii.

Definition charToNibble c : NIBBLE :=
  fromNat (findex 0 (String c EmptyString) "0123456789ABCDEF0123456789abcdef").
Definition charToBit c : bool := ascii_dec c "1".

(*---------------------------------------------------------------------------
 from Binary string to BITS n
 ---------------------------------------------------------------------------*)
Fixpoint fromBin s : BITS (length s) :=
  if s is String c s
  then joinmsb (charToBit c, fromBin s) else #0.

(*--------------------------------------------------------------------------
 from Hex string to BITS n
 --------------------------------------------------------------------------*)
Fixpoint fromHex s : BITS (length s * 4) :=
  if s is String c s
  then joinNibble (charToNibble c) (fromHex s) else #0.

(*--------------------------------------------------------------------------
 from character string to BITS n
 --------------------------------------------------------------------------*)
Fixpoint fromString s : BITS (length s * 8) :=
  if s is String c s return BITS (length s * 8)
  then fromString s ## fromNat (n:=8) (nat_of_ascii c) else nilB.

(*-------------------------------------------------------------------------*)
Definition nibbleToChar (n: NIBBLE) :=
  match String.get (toNat n) "0123456789ABCDEF" with None => " "%char | Some c => c end.

(*-------------------------------------------------------------------------*)
Definition appendNibbleOnString n s :=
  (s ++ String.String (nibbleToChar n) EmptyString)%string.

End HexStrings.

(*--------------------------------------------------------------------------
 from BITS n to Hex string in Big Ediant representation
 --------------------------------------------------------------------------*)
Fixpoint toHex {n} :=
  match n return BITS n -> string with
  | 0 => fun bs => EmptyString
  | 1 => fun bs => appendNibbleOnString (zero 3 ## bs) EmptyString
  | 2 => fun bs => appendNibbleOnString (zero 2 ## bs) EmptyString
  | 3 => fun bs => appendNibbleOnString (zero 1 ## bs) EmptyString
  | _ => fun bs => let (hi,lo) := split2 _ 4 bs in appendNibbleOnString lo (toHex hi)
  end.

(*----------------------------------------------------------------------------
 from sequences of BYTEs, ADDRESSes, and EVMWORDs to Hex strings.
 ----------------------------------------------------------------------------*)
Import Ascii.

(* Convert an ASCII character (from the standard Coq library) to a BYTE *)
Definition charToBYTE (c: ascii) : BYTE :=
  let (a0,a1,a2,a3,a4,a5,a6,a7) := c in
  [tuple a0;a1;a2;a3;a4;a5;a6;a7].

(* Convert an ASCII string to a tuple of BYTEs... *)
Fixpoint stringToTupleBYTE (s : string) : (length s).-tuple BYTE :=
  if s is String c s then cons_tuple (charToBYTE c) (stringToTupleBYTE s)
  else nil_tuple _.

(* Which is easily coerced to a sequence *)
Definition stringToSeqBYTE (s: string) : seq BYTE :=
  stringToTupleBYTE s.

(* Notation for hex, binary, and character/string *)
Notation "#x y" := (fromHex y) (at level 0).
Notation "#b y" := (fromBin y) (at level 0).
Notation "#c y" := (fromString y : BYTE) (at level 0).

(* BYTEs to Hex with spaces like 01 0A 0C, preserve the order in seq *)

Fixpoint bytesToHexAux (b : seq BYTE) (res : string) :=
  match b with
    | b::bs => bytesToHexAux bs (res ++ " " ++ (toHex b))
    | nil => res
  end.

(* Note that the string representation in BE *)
Definition bytesToHex b :=
  bytesToHexAux b ""%string.

(* ADDRESSes to Hex with spaces *)
Fixpoint addressesToHexAux (a : seq ADDRESS) (res : string) :=
  match a with
    | x::xs => addressesToHexAux xs (res ++ " " ++ (toHex x))
    | nil => res
  end.

Definition addressesToHex a :=
  addressesToHexAux a ""%string.

(* EVMWORDs to Hex with spaces *)
Fixpoint evmwordsToHexAux (evmw : seq EVMWORD) (res : string) :=
  match evmw with
    | x::xs => evmwordsToHexAux xs (res ++ " " ++ (toHex x))
    | nil => res
  end.

Definition evmwordsToHex evmw :=
  evmwordsToHexAux evmw ""%string.

(*-------------------------------------------------------------------------------
 BITS n to string preserving the order of bits
 -------------------------------------------------------------------------------*)
Definition appendBitOnString b s :=
  (if b then "1" ++ s else "0" ++ s)%string.

Fixpoint toString {n} :=
  match n return BITS n -> string with
  | 0 => fun bs => EmptyString
  | _ => fun bs => appendBitOnString (thead bs) (toString (behead_tuple bs))

  end.

(*-------------------------------------------------------------------------------
 Unit test.
 -------------------------------------------------------------------------------*)
Example fortytwo  := #42 : BYTE.
Example fortytwo1 := #x"2A".
Example fortytwo2 := #b"00101010".
Example fortytwo3 := #c"*".
Example overflowbyte := #300 : BYTE.
Compute (toString fortytwo2).
Compute (toString fortytwo1).
Compute (toHex fortytwo2).

(* tuple of 5 BYTEs *)
Example bs : 5.-tuple BYTE := [tuple (#5:BYTE); (#4:BYTE); (#3:BYTE); (#2:BYTE); (#1:BYTE)].
Compute (bytesToHex bs).

Example fbs := fromBytes bs.
Compute (toString fbs).
Compute (toHex fbs).
Compute (toHex (lowWithZeroExtendToEVMWORD fbs)).
Compute (toHex (lowWithZeroExtendToBYTE fbs)).

(* tuple of 5 ADDRESSes *)
Example adds : 5.-tuple ADDRESS := [tuple (#5:ADDRESS); (#4:ADDRESS); (#3:ADDRESS); (#2:ADDRESS); (#1:ADDRESS)].
Compute (addressesToHex adds).

(* tuple of 5 EVMWORDs *)
Example ws : 5.-tuple EVMWORD := [tuple (#5:EVMWORD); (#4:EVMWORD); (#3:EVMWORD); (#2:EVMWORD); (#1:EVMWORD)].
Compute (evmwordsToHex ws).


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)

Require Import bedrock.prelude.base.

#[local] Open Scope Z_scope.

(* Bit-widths *)
Variant bitsize : Set :=
| W8
| W16
| W32
| W64
| W128.
#[global] Instance bitsize_eq: EqDecision bitsize.
Proof. solve_decision. Defined.
#[global] Instance bitsize_countable : Countable bitsize.
Proof.
  apply (inj_countable'
    (λ b,
      match b with
      | W8 => 0 | W16 => 1 | W32 => 2 | W64 => 3 | W128 => 4
      end)
    (λ n,
      match n with
      | 0 => W8 | 1 => W16 | 2 => W32 | 3 => W64 | 4 => W128
      | _ => W8	(* dummy *)
      end)).
  abstract (by intros []).
Defined.

Definition bitsN (s : bitsize) : N :=
  match s with
  | W8   => 8
  | W16  => 16
  | W32  => 32
  | W64  => 64
  | W128 => 128
  end.

#[global] Instance bitsN_inj : Inj (=) (=) bitsN.
Proof. red; intros x y H; by (destruct x; destruct y). Qed.

Definition bitsZ (s : bitsize) : Z :=
  Z.of_N (bitsN s).

Definition bytesNat (s : bitsize) : nat :=
  match s with
  | W8 => 1
  | W16 => 2
  | W32 => 4
  | W64 => 8
  | W128 => 16
  end.

Definition bytesN (s : bitsize) : N :=
  N.of_nat (bytesNat s).

Definition bytesZ (s : bitsize) : Z :=
  Z.of_N (bytesN s).

Bind Scope N_scope with bitsize.

Lemma of_size_gt_O w :
  (0 < 2 ^ bitsZ w)%Z.
Proof. destruct w; reflexivity. Qed.
(* Hint Resolve of_size_gt_O. *)

(* Signed and Unsigned *)
Variant signed : Set := Signed | Unsigned.
#[global] Instance signed_eq_dec: EqDecision signed.
Proof. solve_decision. Defined.
#[global] Instance signed_countable : Countable signed.
Proof.
  apply (inj_countable'
    (λ s, if s is Signed then true else false)
    (λ b, if b then Signed else Unsigned)).
  abstract (by intros []).
Defined.

Variant endian : Set := Little | Big.
#[global] Instance endian_dec : EqDecision endian.
Proof. solve_decision. Defined.

Definition max_val (bits : bitsize) (sgn : signed) : Z :=
  match bits , sgn with
  | W8   , Signed   => 2^7 - 1
  | W8   , Unsigned => 2^8 - 1
  | W16  , Signed   => 2^15 - 1
  | W16  , Unsigned => 2^16 - 1
  | W32  , Signed   => 2^31 - 1
  | W32  , Unsigned => 2^32 - 1
  | W64  , Signed   => 2^63 - 1
  | W64  , Unsigned => 2^64 - 1
  | W128 , Signed   => 2^127 - 1
  | W128 , Unsigned => 2^128 - 1
  end.

Definition min_val (bits : bitsize) (sgn : signed) : Z :=
  match sgn with
  | Unsigned => 0
  | Signed =>
    match bits with
    | W8   => -2^7
    | W16  => -2^15
    | W32  => -2^31
    | W64  => -2^63
    | W128 => -2^127
    end
  end.

Definition bound (bits : bitsize) (sgn : signed) (v : Z) : Prop :=
  min_val bits sgn <= v <= max_val bits sgn.


(** Proving that the determinant Mk <> 0 for the example problem *)
Require Import Reals Psatz.
Require Import Coquelicot.Hierarchy.
Require Import Omega Init.Nat Arith.EqNat.
Require Import Coq.Arith.PeanoNat.
Require Import combinatorics.
Require Import Arith.Even Div2.
Require Import Ah_inverse.

Lemma Mk_0: Mk 0%nat (-2) = 1.
Proof.
unfold Mk. simpl. unfold sum_n.
assert (sum_n_m (fun i : nat => det_func (-2) 0 i) 0 0=(fun i : nat => det_func (-2) 0 i) 0%nat).
{ apply (sum_n_n (fun i : nat => det_func (-2) 0 i) 0%nat). } rewrite H.
unfold det_func. simpl.
assert (nchoosek 0 0 =1). { apply comb_prop_1. } rewrite H0. nra.
Qed.

Lemma Mk_1: Mk 1%nat (-2) = -2.
Proof.
unfold Mk. simpl. unfold sum_n.
assert (sum_n_m (fun i : nat => det_func (-2) 1 i) 0 0 =(fun i : nat => det_func (-2) 1 i) 0%nat).
{ apply (sum_n_n (fun i : nat => det_func (-2) 1 i) 0%nat). } rewrite H.
unfold det_func. simpl.
assert ( nchoosek 1 0=1). { apply comb_prop_1. }rewrite H0. nra.
Qed.

Lemma Mk_2: Mk 2 (-2) =3.
Proof.
unfold Mk. simpl. unfold sum_n.
assert (sum_n_m (fun i : nat => det_func (-2) 2 i) 0 1 =sum_n_m (fun i : nat => det_func (-2) 2 i) 0%nat 0%nat +
          sum_n_m (fun i : nat => det_func (-2) 2 i) 1%nat 1%nat).
{ apply (sum_n_m_Chasles (fun i : nat => det_func (-2) 2 i) 0%nat 0%nat 1%nat). omega. omega. } rewrite H.
assert (sum_n_m (fun i : nat => det_func (-2) 2 i) 0 0=(fun i : nat => det_func (-2) 2 i) 0%nat).
{ apply (sum_n_n (fun i : nat => det_func (-2) 2 i) 0%nat). } rewrite H0.
assert (sum_n_m (fun i : nat => det_func (-2) 2 i) 1 1=(fun i : nat => det_func (-2) 2 i) 1%nat).
{ apply (sum_n_n (fun i : nat => det_func (-2) 2 i) 1%nat). } rewrite H1.
unfold det_func. simpl.
assert (nchoosek 2 0=1). { apply comb_prop_1. } rewrite H2.
assert (nchoosek 1 1=1). { apply comb_prop_2. omega. } rewrite H3.
nra.
Qed.

Lemma Mk_3: Mk 3 (-2) = -4.
Proof.
unfold Mk. simpl. unfold sum_n.
assert (sum_n_m (fun i : nat => det_func (-2) 3 i) 0 1=sum_n_m (fun i : nat => det_func (-2) 3 i) 0%nat 0%nat +
          sum_n_m (fun i : nat => det_func (-2) 3 i) 1%nat 1%nat).
{ apply (sum_n_m_Chasles (fun i : nat => det_func (-2) 3 i) 0%nat 0%nat 1%nat). omega. omega. } rewrite H.
assert (sum_n_m (fun i : nat => det_func (-2) 3 i) 0 0= (fun i : nat => det_func (-2) 3 i) 0%nat).
{ apply (sum_n_n (fun i : nat => det_func (-2) 3 i) 0%nat). } rewrite H0.
assert (sum_n_m (fun i : nat => det_func (-2) 3 i) 1 1=(fun i : nat => det_func (-2) 3 i) 1%nat).
{ apply (sum_n_n (fun i : nat => det_func (-2) 3 i) 1%nat). } rewrite H1.
unfold det_func. simpl.
assert (nchoosek 3 0=1). { apply comb_prop_1. } rewrite H2.
assert ( nchoosek 2 1 =2). { apply comb_prop_2. omega. } rewrite H3.
nra.
Qed.

Require Import Coq.Program.Equality Coq.Init.Wf.

(* We used the code snippets for lemma/theorem le_s, strongind_aux, weaken and strongind from
    http://pldev.blogspot.com/2012/02/proving-strong-induction-principle-for.html
*)

Lemma le_S :
  forall n m : nat,
    (n <= S m)%nat -> (n <= m)%nat \/ n = S m.
Proof.
  intros.
  inversion H.
  right. reflexivity.
  left. assumption.
Qed.

Theorem strongind_aux :
 Mk 0%nat (-2) = (-1)^0%nat * (INR 0+1) ->
  (forall n:nat, (forall m:nat, (m <= n)%nat -> Mk m (-2) = (-1)^m * (INR m +1)) ->  Mk (S n) (-2)= (-1)^(S n)* (INR (S n)+1)) ->
  forall n:nat, (forall m:nat, ((m <= n)%nat -> Mk m (-2) = (-1)^m * (INR m +1))).
Proof.
  induction n as [ | n' IHn' ].
    intros m H1.
    inversion H1.
    assumption.
    intros.
    assert ((m <= n')%nat \/ m = S n'). apply le_S. assumption.
    inversion H2.
    apply IHn'; assumption.
    rewrite H3.
    apply (H0 n'); assumption.
Qed.

Lemma weaken :
  (forall n:nat, (forall m:nat, ((m <= n)%nat -> Mk m (-2) = (-1)^m * (INR m +1)))) -> (forall n:nat, Mk n (-2) = (-1)^n * (INR n +1)).
Proof.
intros H n.
apply (H n n).
apply le_n.
Qed.

Theorem strong_ind:
Mk 0%nat (-2) = (-1)^0%nat * (INR 0+1) ->
(forall n:nat, (forall m:nat, (m <= n)%nat -> Mk m (-2) = (-1)^m * (INR m +1)) -> Mk (S n) (-2)= (-1)^(S n)* (INR (S n)+1)) ->
  forall n:nat, Mk n (-2) = (-1)^n * (INR n +1).
Proof.
intros.
intros.
apply weaken.
apply strongind_aux;assumption.
Qed.

Lemma Mk_rec: forall k:nat, Mk k (-2) = (-1)^k * (INR k+1).
Proof.
apply strong_ind.
+ simpl. assert (Mk 0 (-2)=1). { apply Mk_0. } rewrite H. nra.
+ intros.
  assert ( (n<=1)%nat \/ (1<n)%nat). { omega. } destruct H0.
  - assert (n=0%nat \/ n=1%nat). { omega. } destruct H1.
    * rewrite H1. simpl. assert (Mk 1 (-2)=-2). { apply Mk_1. } rewrite H2. nra.
    * rewrite H1. simpl. assert (Mk 2 (-2) =3). { apply Mk_2. }rewrite H2. nra.
  - assert (INR (S n) + 1 = (2* (INR n +1) - INR n)).
  { assert (S n = (n+1)%nat). { omega. } rewrite H1.
    assert (INR (n + 1)=INR n + INR 1). { apply plus_INR. } rewrite H2.
    assert ( INR 1 = 1). { reflexivity. } rewrite H3. nra.
  } rewrite H1.
  assert ( S n = (n+1)%nat). { omega. }rewrite H2.
  assert ((-1) ^ (n + 1)= (-1)^ n * (-1)^1). { apply pow_add. } rewrite H3.
  assert ((-1) ^ n * (-1) ^ 1 * (2 * (INR n + 1) - INR n)= (-1) * ( 2*((-1)^n * (INR n +1)) - (-1)^n * INR n)).
  { nra. } rewrite H4.
  rewrite <-H.
  assert ((-1) ^ n * INR n= (-1) * ((-1)^(n-1)%nat * (INR (n-1) +1))).
  { assert (-1 * ((-1) ^ (n - 1) * (INR (n - 1) + 1))= ((-1)^(n-1)%nat * (-1)^1) * (INR (n-1) +1)). { nra. } rewrite H5.
    assert ((-1)^ ((n-1)+1)%nat = (-1)^ (n-1)%nat * (-1)^1). { apply pow_add. } rewrite <-H6.
    assert ((n - 1 + 1)%nat= n). { nia. } rewrite H7.
    assert (INR (n - 1)= INR n - INR 1). { apply minus_INR. nia. } rewrite H8.
    assert (INR 1=1). { reflexivity. } rewrite H9.  nra.
  } rewrite H5.
  assert (Mk (n-1)%nat (-2) = (-1) ^ (n - 1) * (INR (n - 1) + 1)). { specialize (H (n-1)%nat).
  assert ((n - 1 <= n)%nat). { nia. } specialize (H H6). apply H. } rewrite <-H6.
  assert ((2 * Mk n (-2) - -1 * Mk (n - 1) (-2))=(2 * Mk n (-2) + Mk (n - 1) (-2))). { nra. } rewrite H7.
  assert (-1 * (2 * Mk n (-2) + Mk (n - 1) (-2))= -2 * Mk n (-2) - Mk (n-1)%nat (-2)). { nra. } rewrite H8.
  assert (n = ((n+1)-1)%nat). { nia. }
  assert ( (n-1)%nat = ((n+1)-2)%nat). {  nia. }
  assert (Mk n (-2)= Mk ((n+1)-1)%nat (-2)). { rewrite <-H9. reflexivity. } rewrite H11.
  assert (Mk (n - 1) (-2)= Mk ((n+1)-2)%nat (-2)).  { rewrite <-H10. reflexivity. } rewrite H12. apply Ah_inverse.Mk_recurr. nia.
Qed.

Lemma Mk_not_0: forall N:nat,  Mk N (-2) <> 0.
Proof.
intros.
assert (Mk N (-2) = (-1)^N * (INR N+1)). { apply Mk_rec. } rewrite H.
apply Rmult_integral_contrapositive_currified.
apply pow_nonzero. nra.
assert (INR (N+1)= INR N + INR 1). { apply plus_INR. } assert (INR 1 = 1). { reflexivity. } rewrite <-H1. rewrite <-H0.
assert ( 0< INR (N+1) -> INR (N + 1) <> 0). { nra. } apply H2. apply lt_0_INR. omega.
Qed.


(* Require Import domains. *)
Require Import maps.
Require Import Setoid.

Set Implicit Arguments.

(* Define a language of map patterns.
   A map pattern is basically just a pattern over maps,
   but hidden under a definition so it doesn't reduce
   too eagerly, and with standard definitions of
   patterns for items, union, literal, and empty maps.
   Particular interesting are existential quantifers.

   Specifications are expected to define their own
   predicates, which should be possible in terms
   of these primitives.
 *)

Section Pattern.
Variables (Key Elt : Type).

(* A pattern is a predicate on maps which respects map equivalence.
   The predicate and proof are packaged together to be sure we
   can't accidentally use ill-defined predicates as patterns. *)
Definition MapPattern' := Map Key Elt -> Prop.
Definition GoodPat (P : MapPattern') : Prop :=
  forall h1 h2, h1 ~= h2 -> (P h1 <-> P h2).
Definition MapPattern : Type :=
  { P : Map Key Elt -> Prop | GoodPat P }.

(**
A map satisfies a predicate if the predicate holds on a map.
These definitions also seem to mostly prevent simpl from
unfolding applications of "satsifies".
(we can explicitly "unfold satisfies" for proving lemmas)
 *)
Definition satisfies (c : Map Key Elt) (P : MapPattern) : Prop := proj1_sig P c.

(** Now come the pasic patterns *)

(** An empty map *)
Definition emptyP : MapPattern.
refine (exist _ (fun h => h ~= mapEmpty) _).
abstract (unfold GoodPat;simpl;split;intuition;equate_maps).
Defined.

(** A single item *)
Definition itemP (k : Key) (v : Elt) : MapPattern.
refine (exist _ (fun h => h ~= k |-> v) _).
abstract (split;intros;equate_maps).
Defined.

(** Joining two patterns *)
Definition joinP (mp1 mp2 : MapPattern) : MapPattern.
refine (exist _ (fun h => exists h1, exists h2,
  satisfies h1 mp1 /\ satisfies h2 mp2 /\ h ~= h1 :* h2) _).
abstract (split;destruct 1 as [? []];eexists;eexists;intuition eauto;equate_maps).
Defined.

(** Making a pattern from an entire concrete map *)
Definition litP (h : Map Key Elt) : MapPattern.
refine (exist _ (fun m => m ~= h) _).
abstract (split;intros;equate_maps).
Defined.

(**
Embedding a pure predicate as a map pattern.
Satisfiable only if the predicate is true, and then matches an empty map.
*)
Definition constraint (P : Prop) : MapPattern.
refine (exist _ (fun h => P /\ h ~= mapEmpty) _).
  abstract(split;intuition;equate_maps).
Defined.

(** Now for two slightly more involved things *)

(** Patterns can include existential qunantification.

This is necessary as parts of things like patterns for linked lists,
where we need to existentially quantify over the address of the
second node
*)
Definition exP {A : Type} (P : A -> MapPattern) : MapPattern.
refine (exist _ (fun h => exists (x : A), satisfies h (P x)) _).
abstract (unfold GoodPat,satisfies;split;destruct 1;
   destruct (proj2_sig (P x) _ _ H);eauto).
Defined.

(** The last pattern we define is more specialized.
It matches a specific map, but also records that the map
satisfies a pattern.

This is somewhat specialized.

It is intended to be used mostly with map variables where
all we know about them is that they satisfy some pattern.
If we want to prove pattern implications with a pattern
involving asP on the left, we can handle desired patterns
that either want the exact submap, or just care about the
property.
*)
Definition asP (h : Map Key Elt) (P : MapPattern) : MapPattern.
refine (exist _ (fun h' => h' ~= h /\ satisfies h P) _).
unfold GoodPat,satisfies;split;destruct 1;
   (split;[equate_maps|assumption]).
Defined.

End Pattern.

(** Next we define notations for writing patterns.

The same notations are used for the basic item/join/empty patterns
as for the map constructors.
They are put in a different notation scope, which is automatically
added in appropriate arguments of the pattern operators,
so there should be no confusion with maps.
 *)
Delimit Scope MapPattern with pattern.
Bind Scope MapPattern with MapPattern.

Notation "h |= p" := (satisfies h%Map p%pattern) (at level 80, no associativity).

Infix "|->" := itemP (at level 50, no associativity) : MapPattern.

Arguments joinP {Key Elt} (mp1 mp2)%pattern.
Notation "m1 :* m2" := (joinP m1%pattern m2%pattern) (at level 60, right associativity) : MapPattern.

(* Using a name as a notation shadows any ordinary identifier,
   so we need to redeclare mapEmpty for Map as a notation too *)
Arguments emptyP {Key Elt}.
Notation "'mapEmpty'" := mapEmpty : Map.
Notation "'mapEmpty'" := emptyP : MapPattern.

Arguments exP {Key Elt A} P%pattern.
Notation "'existP' x ',' e" :=
  ((exP (fun x =>e))%pattern)
  (at level 70) : MapPattern.
Notation "'existsP' x .. y ',' e" :=
  (exP (fun x => .. (exP (fun y => e)) ..)%pattern)
  (at level 70, x binder, y binder) : MapPattern.

Arguments constraint {Key Elt} P%type.

(**
The next step is to define pattern equivalence and implication,
and enable rewriting by these relations.
*)

(** First, declare PatEquiv as an equivalence relation *)
Definition PatEquiv {Key Elt} (A B : MapPattern Key Elt) :=
  forall h, h |= A <-> h |= B.

Lemma patEquivTrans : forall {Key Elt} (m1 m2 m3 : MapPattern Key Elt), PatEquiv m1 m2 -> PatEquiv m2 m3 -> PatEquiv m1 m3.
Proof. firstorder. Qed.

Lemma patEquivSym : forall {Key Elt} (m1 m2 : MapPattern Key Elt),
                      PatEquiv m1 m2 -> PatEquiv m2 m1.
Proof. firstorder. Qed.

Lemma patEquivRefl : forall {Key Elt} (m : MapPattern Key Elt),
                       PatEquiv m m.
Proof. firstorder. Qed.

Add Parametric Relation Key Elt : (MapPattern Key Elt) PatEquiv
  reflexivity proved by (@patEquivRefl Key Elt)
  symmetry proved by (@patEquivSym Key Elt)
  transitivity proved by (@patEquivTrans Key Elt)
  as pat_equiv_rel.

(** Additionally Show PatEquiv is associative and commutative, with unit emptyP *)

(* A little custom tactic for proving these lemmas about PatEquiv *)
Local Ltac pat_equiv_solver :=
split;(intros;repeat match goal with
| [H : _ |= (_ :* _)%pattern |-_] => destruct H as [? [? [? []]]]
| [H : _ |=  ?P |-_] => progress (simpl in H)
end;
repeat
match goal with
  | [|- _ |= (_ :* _)%pattern] => eexists;eexists;repeat split
  | [H : _ |= ?P |- _ |= ?P] => eexact H
  | [|- _ ~= _] => equate_maps
  | [|- _ |= mapEmpty%pattern] => simpl
  | [H : _ |= ?P |- _ |= ?P] => revert H;apply (proj2_sig P)
  | [H  : PatEquiv ?A ?B |- _ |= ?A] => apply H
  | [H  : PatEquiv ?B ?A |- _ |= ?A] => apply H
  | _ => progress (instantiate;simpl)
end).

Lemma patEquivComm : forall {Key Elt} (m1 m2 : MapPattern Key Elt),
    PatEquiv (m1 :* m2) (m2 :* m1).
Proof. pat_equiv_solver. Qed.

Lemma patEquivAssoc : forall {Key Elt} (m1 m2 m3 : MapPattern Key Elt),
                        PatEquiv ((m1 :* m2) :* m3) (m1 :* (m2 :* m3)).

Proof. pat_equiv_solver. Qed.

Lemma patEquivUnit : forall {Key Elt} (m : MapPattern Key Elt),
                       PatEquiv (m :* mapEmpty) m.
Proof. pat_equiv_solver. Qed.

Lemma patEquivUnitL : forall {Key Elt} (m : MapPattern Key Elt),
                       PatEquiv (mapEmpty :* m) m.
Proof. pat_equiv_solver. Qed.

Lemma patEquivCommAssoc : forall {Key Elt} (m1 m2 m3 : MapPattern Key Elt),
                        PatEquiv (m1 :* m2 :* m3) (m2 :* m1 :* m3).
Proof. pat_equiv_solver. Qed.

(** Now declare appropriate morphisms to allow rewriting by PatEquiv
    equivalences in pattern arguments of operators we have defined so far *)

(** In particular, we can rewrite in the arguments of PatEquiv itself *)
Add Parametric Morphism Key Elt : (@PatEquiv Key Elt) with
  signature PatEquiv ==> PatEquiv ==> iff as pat_equiv_resp_equiv.
Proof. firstorder. Qed.

(** Register satisfies as a morphism from MapEquiv and PatEquiv
    to logical equivalence *)
Add Parametric Morphism Key Elt : (@satisfies Key Elt) with
  signature MapEquiv ==> PatEquiv ==> iff as satisfies_iff.
Proof. pat_equiv_solver. Qed.

Add Parametric Morphism Key Elt : (@asP Key Elt) with
  signature MapEquiv ==> PatEquiv ==> PatEquiv as asP_equiv_mor.
Proof. intros. unfold PatEquiv. simpl. intro.
  rewrite H. rewrite H0. reflexivity. Qed.

(** Register litP as a morphism from MapEquiv to PatEquiv *)
Add Parametric Morphism Key Elt : (@litP Key Elt) with
  signature MapEquiv ==> PatEquiv as pat_lit_mor.
Proof. pat_equiv_solver. Qed.

(** Register joinP as a congruence for PatEquiv *)
Add Parametric Morphism Key Elt : (@joinP Key Elt) with
  signature PatEquiv ==> PatEquiv ==> PatEquiv as pat_equiv_join_mor.
Proof. pat_equiv_solver. Qed.

(** Next, we make define pattern implication, and register it as
    a reflexive-transitive relation, which also enables some
    rewriting tactics *)
Definition PatImpl {Key Elt : Type} (A B : MapPattern Key Elt) : Prop :=
  forall h, h |= A -> h |= B.

Lemma patImplRefl : forall {Key Elt} (m : MapPattern Key Elt),
                       PatImpl m m.
Proof. firstorder. Qed.

Lemma patImplTrans : forall {Key Elt} (m1 m2 m3 : MapPattern Key Elt),
                       PatImpl m1 m2 -> PatImpl m2 m3 -> PatImpl m1 m3.
Proof. firstorder. Qed.

Add Parametric Relation Key Elt : (MapPattern Key Elt) PatImpl
  reflexivity proved by (@patImplRefl Key Elt)
  transitivity proved by (@patImplTrans Key Elt)
  as pat_impl_rel.

(** PatEquiv is a subrelation of PatImpl and inverse PatImpl. *)
Require Import Coq.Classes.Morphisms.
Instance map_pat_equiv_impl_subrelation : forall {Key Elt : Type},
  subrelation (@PatEquiv Key Elt) PatImpl | 2.
Proof. firstorder. Qed.

Instance map_pat_equiv_inverse_impl_subrelation : forall {Key Elt : Type},
  subrelation (@PatEquiv Key Elt) (inverse PatImpl) | 2.
Proof. firstorder. Qed.

(** We also define various morphisms respecting PatImpl *)

(** In particular, argument to PatImpl itself can be rewritten with PatImpl *)
Add Parametric Morphism Key Elt : (@PatImpl Key Elt) with
  signature PatImpl --> PatImpl ++> Basics.impl as pat_impl_resp_impl.
Proof. firstorder. Qed.
Add Parametric Morphism Key Elt : (@PatImpl Key Elt) with
  signature PatEquiv ==> PatEquiv ==> iff as pat_impl_resp_equiv.
Proof. firstorder. Qed.

Add Parametric Morphism Key Elt : (@joinP Key Elt) with
  signature PatImpl ==> PatImpl ==> PatImpl as patImplJoin.
Proof. firstorder. Qed.

Add Parametric Morphism Key Elt : (@satisfies Key Elt) with
  signature MapEquiv ==> PatImpl ==> Basics.impl as satisfies_impl.
Proof.
unfold PatImpl, Basics.impl, satisfies; firstorder;apply H0.
revert H H1;apply (proj2_sig x0).
Qed.

Add Parametric Morphism Key Elt : (@asP Key Elt) with
  signature MapEquiv ++> PatImpl ++> PatImpl as pat_impl_asP_mor.
Proof. intros. unfold PatImpl. firstorder. equate_maps.
  rewrite <- H, <- H0. assumption. Qed.

(*
Add Parametric Morphism Key Elt : (@asP Key Elt) with
  signature MapEquiv ==> PatEquiv ==> PatEquiv as pat_equiv_as_mor.
unfold PatEquiv;simpl;intuition;try equate_maps.
apply H0;eauto using pats_good.
symmetry in H.
apply H0;eauto using pats_good.
Qed.

*)

Lemma pats_good {Key Elt} (h1 h2 : Map Key Elt) P : h1 ~= h2 -> h1 |= P -> h2 |= P.
Proof. apply (proj2_sig P). Qed.

Lemma asP_forget_heap : forall Key Elt h (P : MapPattern Key Elt),
  PatImpl (asP h P) P.
Proof.
unfold PatImpl. firstorder.
symmetry in H. revert H H0. apply pats_good.
Qed.

Lemma asP_forget_pat : forall Key Elt h (P : MapPattern Key Elt),
  PatImpl (asP h P) (litP h).
unfold PatImpl;simpl;intuition.
Qed.

Lemma constraint_true_simpl : forall {Key Elt} (P : Prop),
  P -> PatEquiv (constraint P) (emptyP : MapPattern Key Elt).
Proof. firstorder. Qed.

(* Seems like this ought to be enough to support rewriting? *)
(*

(* Now, about extracting things *)
Lemma item_split_iff_pat : forall Key Elt (k : Key) (v : Elt)
  (h : Map Key Elt) (P : MapPattern Key Elt),
  h |= k |-> v :* P <-> exists m, h ~= k |-> v :* m /\ m |= P.
split;intros;simpl in * |- *;decompose record H;clear H;
repeat eexists;repeat split;(eassumption || equate_maps).
Qed.

Lemma item_split_manifest : forall Key Elt (k : Key) (v : Elt) (h : Map Key Elt)
  (P : MapPattern Key Elt),
  Basics.impl (h |= P) (k |-> v :* h |= k |-> v :* P).
intros.
simpl.
eexists;eexists;repeat split;eassumption || equate_maps.
Qed.

Lemma lit_split_iff : forall Key Elt (h m : Map Key Elt) P,
  h |= litP m :* P <-> (exists h', h ~= m :* h' /\ h' |= P).
split;intros;simpl in * |- *;decompose record H;clear H;
repeat eexists;repeat split;(eassumption || equate_maps).
Qed.

Lemma lit_split_manifest : forall Key Elt (m h : Map Key Elt)
  (P : MapPattern Key Elt),
  (h |= P) -> (m :* h |= litP m :* P).
intros.
simpl.
eexists;eexists;repeat split;eassumption || equate_maps.
Qed.

*)

Global Opaque satisfies.


From discprob.basic Require Import base order nify seq_ext.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat bigop fintype binomial.
Require Import Coq.omega.Omega Coq.Program.Wf.

Lemma uphalf_le n m:
  n <= m →
  uphalf n <= uphalf m.
Proof.
  move /leP => Hle. induction Hle.
  - done.
  - nify; etransitivity; first apply IHHle. clear.
    induction m => //=; first omega.
    rewrite ?uphalf_half; destruct (odd m); nify; omega.
Qed.

Lemma half_double_lt m n: m < n./2 → (m.*2 < n).
Proof.
  assert (Hlt: 0 < 2) by auto.
  rewrite -(ltn_pmul2r Hlt) -{2}(odd_double_half n). rewrite -?muln2.
  destruct (odd n) => //= ?; nify; omega.
Qed.

Lemma uphalf_sum_edge_odd n:
  odd n →
  \sum_(0 <= i < n) (if i + i < n.+1 then 1 else 0) =
  uphalf n.
Proof.
  assert (0 = n ∨ 0 < n)%coq_nat as [Heq|Hgt0] by omega.
  { subst. rewrite ?big_geq => //=. }

  transitivity (\sum_(0 <= i < uphalf n) 1); last first.
  { rewrite sum_nat_const_nat. nify. omega. }

  symmetry; rewrite (big_nat_widen 0 _ n); last first.
  { rewrite -{2}(uphalf_double n). apply uphalf_le; nify; omega. }

  rewrite -big_mkcondr //=. eapply eq_bigl.
             intros k. rewrite addnn. apply /ltP; case: ifP.
  - intros Hlt.
    assert (Hle': k.*2 <= n) by (nify; omega).
    apply half_leq in Hle'. nify.
    eapply le_lt_trans; eauto.
    rewrite //= uphalf_half. destruct (odd n) => //=.
  - move /negbT/ltP => Hlt Hlt'.
    apply Hlt. apply /ltP/half_double_lt. nify. done.
Qed.

Lemma uphalf_sum_edge_even n:
  ~~ odd n →
  \sum_(0 <= i < n) (if i + i < n then 1 else 0) =
  uphalf n.
Proof.
  intros Heven.
  assert (0 = n ∨ 0 < n)%coq_nat as [Heq|Hgt0] by omega.
  { subst. rewrite ?big_geq => //=. }

  transitivity (\sum_(0 <= i < uphalf n) 1); last first.
  { rewrite sum_nat_const_nat. nify. omega. }

  symmetry; rewrite (big_nat_widen 0 _ n); last first.
  { rewrite -{2}(uphalf_double n). apply uphalf_le; nify; omega. }

  rewrite -big_mkcondr //=. eapply eq_bigl.
  intros k. rewrite addnn. apply /ltP; case: ifP.
  - intros Hlt.
    assert (Hle': k.*2 < n - 1).
    { move /ltP in Hlt. inversion Hlt; last (nify; omega).
      subst. rewrite //= odd_double // in Heven. }
    assert (2 <= n).
    { nify.  destruct n; first omega. destruct n; rewrite //= in Heven; omega. }

    rewrite uphalf_half. destruct (odd n) => //=.
    rewrite add0n.
    apply (le_lt_trans _ (n - 2)./2); last first.
    { assert (n = (S (S (n - 2)))) as Hsum by (nify; omega).
      rewrite {2}Hsum => //=. }
    apply /leP.
    rewrite -(half_double k) half_leq => //.
    nify; omega.
  - move /negbT/ltP => Hlt Hlt'.
    apply Hlt. apply /ltP/half_double_lt. rewrite uphalf_half in Hlt'.
    move: Hlt'. destruct (odd n) => //= ?. nify. omega.
Qed.

Lemma odd_half_double_lt n: odd n → n./2 + n./2 < n.
Proof.
  intros Hodd. rewrite -{3}(half_double n) -addnn halfD Hodd => //=.
Qed.

Lemma lt_addnn: ∀ n i, odd n → i ≠ uphalf n → (i + i < n.+2) = (i + i < n.+1).
Proof.
  intros n i Hodd Hneq.
  apply /ltP; case: ifP.
  - intros; nify; omega.
  - move /ltP. intros Hlt. assert (i + i >= S n) by (nify; omega).
    intros Hfalse.
    cut (i + i <> S n).
    { intros. nify. omega. }
    intros Heq. apply Hneq.
    rewrite addnn in Heq.
    apply (f_equal half) in Heq. rewrite /= in Heq.
    nify. done.
Qed.

Lemma uphalf_sum_rec n:
  odd n →
  \sum_(0 <= i < n.+1) (if i + i < n.+2 then 1 else 0) =
  \sum_(0 <= i < n.+1) (if i + i < n.+1 then 1 else 0) + 1.
Proof.
  rewrite ?big_mkord => Hodd.
  assert (Hlt: (n.+1)./2 < n.+1).
  { destruct n; first by rewrite //=.
    nify. eapply (le_lt_trans _ (S n)); auto.
    rewrite -{2}(half_double (S n)).
    apply /leP.
    apply half_leq.
    nify. omega.
  }
  rewrite (bigD1 (Ordinal Hlt)) //.
  rewrite //=. rewrite addnC; f_equal.
  - rewrite big_mkcond //=. eapply eq_bigr. intros (i&Hlt') _.
    rewrite //=.
    case: ifP => Hneq; last first.
    { case: ifP; auto. intros Hcontra. move /eqP in Hneq.
      inversion Hneq; subst.
      rewrite ?uphalf_half in Hcontra. rewrite Hodd //= in Hcontra.
      rewrite -{3}(half_double n) -addnn halfD Hodd //= in Hcontra.
      nify. omega.
    }
    rewrite lt_addnn => //. intros Heq. subst. move /eqP in Hneq.
    apply /Hneq/ord_inj => //=.
  - case: ifP; auto.
    move /ltP. intros Hn. contradiction Hn.
    rewrite uphalf_half Hodd => //=.
    specialize (odd_half_double_lt n Hodd) => ?.
    nify. omega.
Qed.

Lemma uphalf_sum_half n:
  \sum_(0 <= i < n) (if i < n - i then 1 else 0) = uphalf n.
Proof.
  transitivity (\sum_(0 <= i < n) (if i + i < n then 1 else 0)).
  { rewrite ?big_mkord -?big_mkcond. apply eq_bigl. intros (i&Hlt) => //=.
    apply /ltP. case: ifP; move /ltP; rewrite -?plusE -?minusE => ?; omega.
  }
  rewrite uphalf_half.
  elim: n => [|n IHn]; first by rewrite ?big_geq.
  rewrite //= uphalf_half -IHn.
  rewrite big_nat_recr //=. destruct n => //=.
  - rewrite ?big_geq //=.
  - case: ifP.
    { move /ltP. rewrite -?plusE. intros. exfalso. omega. }
    intros. rewrite addn0.
    case_eq (odd n); last first.
    * intros Heven. rewrite uphalf_sum_edge_odd => //=; last by (rewrite Heven => //).
      rewrite IHn //= uphalf_half !Heven /=. nify. omega.
    * intros Hodd. rewrite uphalf_sum_edge_even => //=; last by (rewrite Hodd => //).
      rewrite //= uphalf_half Hodd //= in IHn.
      rewrite uphalf_sum_rec //= IHn. nify; omega.
Qed.

Lemma uphalf_sum_max n:
\sum_(0 <= i < n) Init.Nat.max i (n.+1 - i - 1) =
\sum_(0 <= i < n) Init.Nat.max i (n - i - 1) + uphalf n.
Proof.
  transitivity (\sum_(0 <= i < n) (Init.Nat.max i (n - i - 1) + (if i < n - i then 1 else 0))).
  { rewrite ?big_mkord.
    eapply eq_bigr. intros (i&Hlt) _ => /=.
    case: ifP => Hlt'.
    - rewrite ?Max.max_r => //=; nify; omega.
    - apply negbT in Hlt'. rewrite -leqNgt in Hlt'.
      rewrite ?Max.max_l => //=; nify; omega.
  }
  rewrite big_split //=. f_equal.
  apply uphalf_sum_half.
Qed.

Lemma max_triangular_sum n : \sum_(0 <= i < n) max i (n - i - 1) = 'C(n, 2) + uphalf n * half n.
Proof.
  elim: n => [|n IHn]; first by rewrite big_geq.
  rewrite big_nat_recr //= binS bin1 Max.max_l; last by (nify; omega).
  rewrite uphalf_sum_max IHn. ring.
Qed.


Require Export Arith Lia List.
Require Export Wellfounded.
Require Export parsing.

(* we need to establish that parsing, as described by the parse_rel
   relation is deterministic.  In other words, the relation actually
   represents a partial function. *)

Theorem parse_rel_fun :
 forall l l1 t1,
   parse_rel l l1 t1 -> forall l2 t2, parse_rel l l2 t2 -> l1 = l2.
Proof.
 intros l l1 t1 Hp1; elim Hp1.
 - intros l2 l3 l4 t2 t3 Hp2 Hrec2 Hp3 Hrec3 l5 t4 H'.
   inversion H'.
   match goal with Hid : parse_rel l2 (close:: _) _ |- _ =>
                   generalize (Hrec2 _ _ Hid) end.
   intros heq1; injection heq1.
   intros heq2; subst l3.
   eapply Hrec3; eauto.

 -  intros l2 t2 Hp2; inversion Hp2; trivial.
 -  intros l0 l2 t2 Hp2; inversion Hp2; trivial.
Qed.

(* We actually develop a function that satisfies a stronger
   specification (see the type of parse_nest_aux2), using well-founded
   induction.  The added information in the stronger type is that the
   string that remains to be parsed has a length that is less than or
   equal to the length of the input string.

   The first case concerns parsing an empty string, this is very
   simple. *)

Definition parse_nest_aux_nil :
  {l'': list par & {t:bin | parse_rel nil l'' t /\ length l'' <= length (A:=par) nil}}+
  {forall l'' t, ~parse_rel nil l'' t}.
Proof.
  left; exists (@nil par); exists L; split; auto.
  apply parse_leaf_nil.
Defined.

(* When parsing a string that starts with an open parenthesis, we need
   to perform two recursive calls, which may both fail.  Moreover, the
   string that remains after the first recursive call needs to start
   with a closing parenthesis.  These constraints give three causes of
   failures of the parser and we prove in each case that the string
   cannot be parsed if this happens.  This relies heavily on the fact
   that the parsing relation is deterministic. *)

Definition parse_nest_aux_open :
  forall l0 : list par,
  (forall l' : list par,
     length l' < S (length l0) ->
     {l'' : list par &
     {t : bin | parse_rel l' l'' t /\ length l'' <= length l'}}+
     {(forall (l'':list par)(t:bin), ~parse_rel l' l'' t)})->
  {l'' : list par &
  {t : bin |
  parse_rel (open::l0) l'' t /\ length l'' <= S (length l0)}}+
  {(forall (l'':list par)(t:bin), ~parse_rel (open :: l0) l'' t)}.

(* We use the refine tactic and we hope this makes the algorithm
   clear: parse the well-parenthesized expression after the opening
   parenthesis, check it is followed by a closing parenthesis, then
   parse an other well-parenthesized expression.  If all this succeeds
   return a result (inleft), if not, return a failure (inright) *)
 refine
   (fun l0 rec =>
      match rec l0 _ with
      | inleft (existT _ (close::l1) (exist _ t1 (conj Hp Hl))) =>
        match rec l1 _ with
        | inleft (existT _ l2 (exist _ t2 (conj Hp2 Hl2))) =>
          inleft _
              (existT  (fun l' => {t:bin | parse_rel (open::l0) l' t /\
                                          length l' <= S (length l0)})
                   l2 (exist _ (N t1 t2) _))
        | inright Hnp => inright _ (fun l'' t' Hp' => _)
        end
      | inleft (existT _ (open::l1) (exist _ t1 (conj Hp Hl))) =>
         inright _ (fun l'' t' Hp' => _)
      | inleft (existT _ nil (exist _ t1 (conj Hp Hl))) =>
         inright _ (fun l'' t' Hp' => _)
      | inright Hnp => inright _ (fun l'' t' Hp' => _)
      end);(auto ||
            (try (inversion Hp';
                  (try
                    match goal with
                    | id:parse_rel _ _ _ |- _ =>
                      generalize (parse_rel_fun _ _ _ Hp _ _ id);
                      discriminate
                    end)))).

 split;[eapply parse_node; eauto | auto].

 (* check that the second recursive call to the parser is done on a
    structurally smaller string. *)
 simpl in Hl; lia.

 match goal with
 | id:parse_rel _ (close::_) _ |- _ =>
   generalize (parse_rel_fun _ _ _ Hp _ _ id); intros Heq;
   injection Heq; intros; subst; unfold not in Hnp; eapply Hnp; eauto
 end.

 unfold not in Hnp; eapply Hnp; eauto.
Defined.

(* When a string starts with a close parenthesis, a new node in the
   "bin" data structure is cosntructed, but no character is removed to
   obtain the string that remains. *)

Definition parse_nest_aux_close :
  forall l0 : list par,
  (forall l' : list par,
     length l' < S (length l0) ->
     {l'' : list par &
     {t : bin | parse_rel l' l'' t /\ length l'' <= length l'}}+
     {(forall (l'':list par)(t:bin), ~parse_rel l' l'' t)})->
  {l'' : list par &
  {t : bin |
  parse_rel (close::l0) l'' t /\ length l'' <= S (length l0)}}+
  {(forall (l'':list par)(t:bin), ~parse_rel (close :: l0) l'' t)}.
Proof.
 intros l0 rec; left; exists (close::l0); exists L.
 split;[constructor | auto].
Defined.

(* This is the function that will be given as argument to
   the  well_founded_induction recursor.  *)

Definition parse_nest_aux :
 forall l: list par,
   (forall l':list par, length l' < length l ->
      {l'': list par & {t:bin | parse_rel l' l'' t /\
                 length l'' <= length l'}}+{forall l'' t, ~parse_rel l' l'' t}) ->
   {l'': list par & { t: bin | parse_rel l l'' t /\
       length l'' <= length l}}+{forall l'' t, ~parse_rel l l'' t}.
 refine
   (fun l =>
      match l return
        (forall l':list par, length l' < length l ->
         {l'': list par & {t:bin | parse_rel l' l'' t /\ length l'' <= length l'}}+
         {forall l'' t, ~parse_rel l' l'' t}) ->
          {l'': list par &
           {t: bin | parse_rel l l'' t /\ length l'' <= length l}}+
           {forall l'' t, ~parse_rel l l'' t}
      with
        nil => (fun rec => parse_nest_aux_nil)
      | cons open l0 => _
      | cons close l0 => _
      end); simpl.
 - apply parse_nest_aux_open.
 -  apply parse_nest_aux_close.
Defined.

Definition parse_nest_aux2 :
 forall l: list par,
  {l'':list par &
     {t:bin |
         parse_rel l l'' t /\ length l'' <= length l}}+
  {forall l'' t', ~parse_rel l l'' t'}.
exact
 (well_founded_induction
    (wf_inverse_image (list par) nat lt (@length par) Wf_nat.lt_wf)
    (fun l =>
       {l'': list par &
         {t:bin | parse_rel l l'' t /\ length l'' <= length l}}+
       {forall l'' t', ~parse_rel l l'' t'})
    parse_nest_aux).
Defined.

Definition parse_nest :
 forall l: list par,
  {l'':list par &
   {t:bin | parse_rel l l'' t}}+{forall l'' t', ~parse_rel l l'' t'}.
Proof.
intros l; elim (parse_nest_aux2 l).
- intros (l'', (t, (Hp, Hl))); left; exists l''; exists t; exact Hp.
- intros Hnp; right; exact Hnp.
Defined.


From Hammer Require Import Hammer.

Require Export QArith_base.
Require Import Znumtheory.

Notation Z2P := Z.to_pos (compat "8.3").
Notation Z2P_correct := Z2Pos.id (compat "8.3").

Definition Qred (q:Q) :=
let (q1,q2) := q in
let (r1,r2) := snd (Z.ggcd q1 ('q2))
in r1#(Z.to_pos r2).

Lemma Qred_correct : forall q, (Qred q) == q.
Proof. hammer_hook "Qreduction" "Qreduction.Qred_correct".
unfold Qred, Qeq; intros (n,d); simpl.
generalize (Z.ggcd_gcd n ('d)) (Z.gcd_nonneg n ('d))
(Z.ggcd_correct_divisors n ('d)).
destruct (Z.ggcd n (Zpos d)) as (g,(nn,dd)); simpl.
Open Scope Z_scope.
intros Hg LE (Hn,Hd). rewrite Hd, Hn.
rewrite <- Hg in LE; clear Hg.
assert (0 <> g) by (intro; subst; discriminate).
rewrite Z2Pos.id. ring.
rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hd | omega].
Close Scope Z_scope.
Qed.

Lemma Qred_complete : forall p q,  p==q -> Qred p = Qred q.
Proof. hammer_hook "Qreduction" "Qreduction.Qred_complete".
intros (a,b) (c,d).
unfold Qred, Qeq in *; simpl in *.
Open Scope Z_scope.
intros H.
generalize (Z.ggcd_gcd a ('b)) (Zgcd_is_gcd a ('b))
(Z.gcd_nonneg a ('b)) (Z.ggcd_correct_divisors a ('b)).
destruct (Z.ggcd a (Zpos b)) as (g,(aa,bb)).
simpl. intros <- Hg1 Hg2 (Hg3,Hg4).
assert (Hg0 : g <> 0) by (intro; now subst g).
generalize (Z.ggcd_gcd c ('d)) (Zgcd_is_gcd c ('d))
(Z.gcd_nonneg c ('d)) (Z.ggcd_correct_divisors c ('d)).
destruct (Z.ggcd c (Zpos d)) as (g',(cc,dd)).
simpl. intros <- Hg'1 Hg'2 (Hg'3,Hg'4).
assert (Hg'0 : g' <> 0) by (intro; now subst g').

elim (rel_prime_cross_prod aa bb cc dd).
- congruence.
-
constructor.
* exists aa; auto with zarith.
* exists bb; auto with zarith.
* intros x Ha Hb.
destruct Hg1 as (Hg11,Hg12,Hg13).
destruct (Hg13 (g*x)) as (x',Hx).
{ rewrite Hg3.
destruct Ha as (xa,Hxa); exists xa; rewrite Hxa; ring. }
{ rewrite Hg4.
destruct Hb as (xb,Hxb); exists xb; rewrite Hxb; ring. }
exists x'.
apply Z.mul_reg_l with g; auto. rewrite Hx at 1; ring.
-
constructor.
* exists cc; auto with zarith.
* exists dd; auto with zarith.
* intros x Hc Hd.
inversion Hg'1 as (Hg'11,Hg'12,Hg'13).
destruct (Hg'13 (g'*x)) as (x',Hx).
{ rewrite Hg'3.
destruct Hc as (xc,Hxc); exists xc; rewrite Hxc; ring. }
{ rewrite Hg'4.
destruct Hd as (xd,Hxd); exists xd; rewrite Hxd; ring. }
exists x'.
apply Z.mul_reg_l with g'; auto. rewrite Hx at 1; ring.
- apply Z.lt_gt.
rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hg4 | omega].
- apply Z.lt_gt.
rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | omega].
- apply Z.mul_reg_l with (g*g').
* rewrite Z.mul_eq_0. now destruct 1.
* rewrite Z.mul_shuffle1, <- Hg3, <- Hg'4.
now rewrite Z.mul_shuffle1, <- Hg'3, <- Hg4, H, Z.mul_comm.
Close Scope Z_scope.
Qed.

Lemma Qred_eq_iff q q' : Qred q = Qred q' <-> q == q'.
Proof. hammer_hook "Qreduction" "Qreduction.Qred_eq_iff".
split.
- intros E. rewrite <- (Qred_correct q), <- (Qred_correct q').
now rewrite E.
- apply Qred_complete.
Qed.

Add Morphism Qred with signature (Qeq ==> Qeq) as Qred_comp.
Proof.
intros. now rewrite !Qred_correct.
Qed.

Definition Qplus' (p q : Q) := Qred (Qplus p q).
Definition Qmult' (p q : Q) := Qred (Qmult p q).
Definition Qminus' x y := Qred (Qminus x y).

Lemma Qplus'_correct : forall p q : Q, (Qplus' p q)==(Qplus p q).
Proof. hammer_hook "Qreduction" "Qreduction.Qplus'_correct".
intros; unfold Qplus'; apply Qred_correct; auto.
Qed.

Lemma Qmult'_correct : forall p q : Q, (Qmult' p q)==(Qmult p q).
Proof. hammer_hook "Qreduction" "Qreduction.Qmult'_correct".
intros; unfold Qmult'; apply Qred_correct; auto.
Qed.

Lemma Qminus'_correct : forall p q : Q, (Qminus' p q)==(Qminus p q).
Proof. hammer_hook "Qreduction" "Qreduction.Qminus'_correct".
intros; unfold Qminus'; apply Qred_correct; auto.
Qed.

Add Morphism Qplus' with signature (Qeq ==> Qeq ==> Qeq) as Qplus'_comp.
Proof.
intros; unfold Qplus'.
rewrite H, H0; auto with qarith.
Qed.

Add Morphism Qmult' with signature (Qeq ==> Qeq ==> Qeq) as Qmult'_comp.
Proof.
intros; unfold Qmult'.
rewrite H, H0; auto with qarith.
Qed.

Add Morphism Qminus' with signature (Qeq ==> Qeq ==> Qeq) as Qminus'_comp.
Proof.
intros; unfold Qminus'.
rewrite H, H0; auto with qarith.
Qed.

Lemma Qred_opp: forall q, Qred (-q) = - (Qred q).
Proof. hammer_hook "Qreduction" "Qreduction.Qred_opp".
intros (x, y); unfold Qred; simpl.
rewrite Z.ggcd_opp; case Z.ggcd; intros p1 (p2, p3); simpl.
unfold Qopp; auto.
Qed.

Theorem Qred_compare: forall x y,
Qcompare x y = Qcompare (Qred x) (Qred y).
Proof. hammer_hook "Qreduction" "Qreduction.Qred_compare".
intros x y; apply Qcompare_comp; apply Qeq_sym; apply Qred_correct.
Qed.

Lemma Qred_le q q' : Qred q <= Qred q' <-> q <= q'.
Proof. hammer_hook "Qreduction" "Qreduction.Qred_le".
now rewrite !Qle_alt, <- Qred_compare.
Qed.

Lemma Qred_lt q q' : Qred q < Qred q' <-> q < q'.
Proof. hammer_hook "Qreduction" "Qreduction.Qred_lt".
now rewrite !Qlt_alt, <- Qred_compare.
Qed.


(** * ∑-categories on objects - a generalization of subcategories *)
Require Import HoTT.Basics HoTT.Types.
Require Import Category.Core Functor.Core Category.Sigma.Core.
Require Functor.Composition.Core Functor.Identity.
Require Import Functor.Paths.
Import Functor.Identity.FunctorIdentityNotations.
Import Functor.Composition.Core.FunctorCompositionCoreNotations.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Notation sigT_type := Coq.Init.Specif.sigT.
Local Notation pr1_type := Overture.pr1.

Local Open Scope morphism_scope.
Local Open Scope functor_scope.

Section sigT_obj.
  Variable A : PreCategory.
  Variable Pobj : A -> Type.

  (** ** Definition of [sigT_obj]-precategory *)
  Definition sigT_obj : PreCategory
    := @Build_PreCategory
         (sigT_type Pobj)
         (fun s d => morphism A (pr1_type s) (pr1_type d))
         (fun x => @identity A (pr1_type x))
         (fun s d d' m1 m2 => m1 o m2)%morphism
         (fun _ _ _ _ => associativity A _ _ _ _)
         (fun _ _ => left_identity A _ _)
         (fun _ _ => right_identity A _ _)
         _.

  (** ** First projection functor *)
  Definition pr1_obj : Functor sigT_obj A
    := Build_Functor
         sigT_obj A
         (@pr1_type _ _)
         (fun s d m => m)
         (fun _ _ _ _ _ => idpath)
         (fun _ => idpath).

  Definition sigT_obj_as_sigT : PreCategory
    := @sig A Pobj (fun _ _ _ => Unit) _ (fun _ => tt) (fun _ _ _ _ _ _ _ => tt).

  Definition sigT_functor_obj : Functor sigT_obj_as_sigT sigT_obj
    := Build_Functor sigT_obj_as_sigT sigT_obj
                     (fun x => x)
                     (fun _ _ => @pr1_type _ _)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Definition sigT_functor_obj_inv : Functor sigT_obj sigT_obj_as_sigT
    := Build_Functor sigT_obj sigT_obj_as_sigT
                     (fun x => x)
                     (fun _ _ m => existT _ m tt)
                     (fun _ _ _ _ _ => idpath)
                     (fun _ => idpath).

  Local Open Scope functor_scope.

  Lemma sigT_obj_eq `{Funext}
  : sigT_functor_obj o sigT_functor_obj_inv = 1
    /\ sigT_functor_obj_inv o sigT_functor_obj = 1.
  Proof.
    split; path_functor; trivial.
    apply path_forall; intros [].
    apply path_forall; intros [].
    apply path_forall; intros [? []].
    reflexivity.
  Qed.

  Definition sigT_obj_compat : pr1_obj o sigT_functor_obj = pr1
    := idpath.
End sigT_obj.

Arguments pr1_obj {A Pobj}.

Module Export CategorySigmaOnObjectsNotations.
  Notation "{ x : A | P }" := (sigT_obj A (fun x => P)) : category_scope.
End CategorySigmaOnObjectsNotations.


(**************************************************************************)
(*  This is part of ATBR, it is distributed under the terms of the        *)
(*         GNU Lesser General Public License version 3                    *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2009-2011: Thomas Braibant, Damien Pous.               *)
(**************************************************************************)

(** Languages form a model of Kleene algebras *)

Require Import Common.
Require Import Classes.
Require Import MxGraph.
Require        Converse.
Require Import List.
Set Implicit Arguments.
Unset Strict Implicit.

Section Def.

  Context {A: Type}.

  (* a language is a predicate of words, i.e., list of letters *)
  Definition lang := list A -> Prop.
  Definition lang_equal (L L': lang): Prop := forall x, L x <-> L' x.
  Definition lang_union (L L': lang): lang := fun x => L x \/ L' x.
  Definition lang_Union I (L: I -> lang): lang := fun x => exists i, L i x.
  Definition lang_inter (L L': lang): lang := fun x => L x /\ L' x.
  Definition lang_comp  (L L': lang): lang := fun x => exists2 u, L u & exists2 v, L' v & x=u++v.
  Definition lang_conv  (L: lang): lang := fun x => L (rev x).
  Definition lang_id: lang := fun x => x=nil.
  Definition lang_empty: lang := fun x => False.
  Definition lang_top: lang := fun x => True.
  Fixpoint lang_iter (L: lang) n: lang :=
    match n with
      | 0 => lang_id
      | S n => lang_comp (lang_iter L n) L
    end.
  Definition lang_star (L: lang): lang := fun x => exists n, lang_iter L n x.

  Program Instance lang_Graph: Graph := {
    T := unit;
    X A B := lang;
    equal A B := lang_equal
  }.
  Next Obligation.
    constructor; unfold lang_equal; repeat intro; firstorder.
  Qed.

  Instance lang_SemiLattice_Ops: SemiLattice_Ops lang_Graph := {
    plus A B := lang_union;
    zero A B := lang_empty
  }.

  Instance lang_Monoid_Ops: Monoid_Ops lang_Graph := {
    dot A B C := lang_comp;
    one A := lang_id
  }.

  Instance lang_Star_Op: Star_Op lang_Graph := {
    star A := lang_star
  }.

  Instance lang_Converse_Op: Converse_Op lang_Graph := {
    conv A B := lang_conv
  }.

  Transparent equal.

  Instance lang_SemiLattice: SemiLattice lang_Graph.
  Proof.
    constructor; compute; firstorder.
  Qed.

  Instance lang_ConverseSemiRing: ConverseIdemSemiRing lang_Graph.
  Proof.
    constructor; (exact lang_SemiLattice || (try solve [intros; compute; firstorder])).

     intros ? ? ? ? L M N x. simpl. unfold lang_comp.
      split; intros [u Hu [v Hv ->]].
       destruct Hv as [v' Hv [w Hw ->]]. repeat eexists; eauto. symmetry. apply app_ass.
       destruct Hu as [v' Hv' [w Hw ->]]. repeat eexists; eauto. apply app_ass.

     intros ? ? L x. simpl. unfold lang_comp.
      split; intro H.
       destruct H as [u -> [v Hv ->]]. assumption.
       exists nil; eauto. reflexivity.

     intros ? ? L x. unfold conv, lang_Converse_Op, lang_conv. rewrite rev_involutive. reflexivity.

     intros ? ? ? L M x. simpl. unfold conv, lang_Converse_Op, lang_conv, lang_comp.
      split; intros [u Hu [v Hv H]].
       assert (Hx: x=rev v++rev u). rewrite <- distr_rev, <- H, rev_involutive. reflexivity.
       rewrite Hx. repeat eexists; rewrite rev_involutive; assumption.
       rewrite H, distr_rev. eauto.
  Qed.

  Definition lang_IdemSemiRing: IdemSemiRing lang_Graph := Converse.CISR_ISR.

  Notation LX := (@X lang_Graph tt tt).

  Lemma lang_leq n m: forall (a b: @X (lang_Graph) n m), a<==b <-> forall x, a x -> b x.
  Proof. compute. firstorder. Qed.

  Lemma lang_Union_spec I (L: I -> LX): forall L': LX, (lang_Union L: LX) <== L' <-> forall i, L i <== L'.
  Proof.
    intros. split; intro H.
    intro j. rewrite <- H. apply <- lang_leq. intros w Hw. exists j; assumption.
    apply <- lang_leq. intros w [j Hw]. setoid_rewrite lang_leq in H. eauto.
  Qed.

  Lemma leq_lang_Union I (L: I -> LX): forall i, L i <== lang_Union L.
  Proof.
    intros. apply -> (lang_Union_spec L). apply plus_idem.
  Qed.

  Instance lang_ConverseKleeneAlgebra: ConverseKleeneAlgebra lang_Graph.
  Proof.
    constructor;
      first [
        exact lang_ConverseSemiRing |
        intros
      ].
    intros p; split; intro H.
    destruct H as [H|[u [n Hu] [v Hv H]]].
    exists O; trivial.
    exists (S n). exists u; trivial. exists v; trivial.
    destruct H as [[|n] H].
    left; trivial.
    right. destruct H as [u Hu [v Hv H]]. exists u; trivial. exists n; trivial. exists v; trivial.

    apply <- lang_leq. intros w [u [n Hu] [v Hv ->]].
    revert u Hu v Hv. induction n; intros u Hu v Hv.
     rewrite Hu. trivial.
     destruct Hu as [x Hx [y Hy ->]].
     rewrite app_ass. apply IHn; trivial.
     apply -> lang_leq; eauto. repeat eexists; trivial.
  Qed.

  Definition lang_KleeneAlgebra: KleeneAlgebra lang_Graph := Converse.CKA_KA.

End Def.

(** Import this module to work with languages *)
Module Load.

  Existing Instance lang_Graph.
  Existing Instance lang_SemiLattice_Ops.
  Existing Instance lang_Monoid_Ops.
  Existing Instance lang_Converse_Op.
  Existing Instance lang_SemiLattice.
  Existing Instance lang_Star_Op.
  Existing Instance lang_KleeneAlgebra.

  Canonical Structure lang_Graph.

  Transparent equal plus dot one zero star.

  Notation LX A := (@X (@lang_Graph A) tt tt).
  Notation LMX A n m := (@X (@mx_Graph (@lang_Graph A) tt) (n%nat) (m%nat)).

  Ltac fold_langAlg A :=
    change (@lang_equal A) with (@equal (@lang_Graph A) tt tt);
      change (@lang_id A) with (@one (@lang_Graph A) (@lang_Monoid_Ops A) tt);
        change (@lang_comp A) with (@dot (@lang_Graph A) (@lang_Monoid_Ops A) tt tt tt);
          change (@lang_union A) with (@plus (@lang_Graph A) (@lang_SemiLattice_Ops A) tt tt);
            change (@lang_empty A) with (@zero (@lang_Graph A) (@lang_SemiLattice_Ops A) tt tt);
              change (@lang_star A) with (@star (@lang_Graph A) (@lang_Star_Op A) tt).

End Load.


(* This file contains the basic definitions of the contraction,
   conversion and reduction relations of the systems CL-pc, CL-pc^1
   and CL-pc^L *)

Require Import general.

(*************************************************************************************)
(* basic definitions of (i-)terms and the reduction relations of CLC0 (CL-pc),
   CLC (CL-pc^1) and CLC+ (CL-pc^L) *)

Inductive iterm :=
| C : iterm
| T : iterm
| F : iterm
| I : iterm
| K : iterm
| Si : iterm
| var : nat -> iterm
| app : iterm -> iterm -> iterm.

Notation "X @i Y" := (app X Y) (at level 11, left associativity).

Inductive CtxClose_i (R : iterm -> iterm -> Prop) : iterm -> iterm -> Prop :=
| close_ibase : forall t1 t2 : iterm, R t1 t2 -> CtxClose_i R t1 t2
| close_iapp_l : forall x x' y : iterm, CtxClose_i R x x' ->
                                         CtxClose_i R (x @i y) (x' @i y)
| close_iapp_r : forall x y y' : iterm, CtxClose_i R y y' ->
                                        CtxClose_i R (x @i y) (x @i y').

Definition EqvClose_i (R : iterm -> iterm -> Prop) := clos_refl_sym_trans iterm (CtxClose_i R).

Definition RootContr_clc_base (R : iterm -> iterm -> Prop) (t1 t2 : iterm) : Prop :=
  match t1 with
  | C @i z @i x @i y =>
    (z = T /\ x = t2) \/ (z = F /\ y = t2) \/ (R x y /\ x = t2)
  | I @i x => x = t2
  | K @i x @i y => x = t2
  | Si @i x @i y @i z =>
    match t2 with
    | x1 @i z1 @i (y1 @i z2) => x = x1 /\ y = y1 /\ z = z1 /\ z = z2
    | _ => False
    end
  | _ => False
  end.

Fixpoint RootContr_clc_n (n : nat) :=
  match n with
  | 0 => RootContr_clc_base (@eq iterm)
  | S m => RootContr_clc_base (EqvClose_i (RootContr_clc_n m))
  end.

Definition Contr_clc_n n := CtxClose_i (RootContr_clc_n n).

Definition RootContr_clc0 := RootContr_clc_n 0.
Definition Contr_clc0 := CtxClose_i RootContr_clc0.
Definition Red_clc0 := clos_refl_trans iterm Contr_clc0.
Definition Eqv_clc0 := EqvClose_i RootContr_clc0.

Definition RootContr_clc x y := exists n, RootContr_clc_n n x y.
Definition Contr_clc := CtxClose_i RootContr_clc.
Definition Red_clc := clos_refl_trans iterm Contr_clc.
Definition Eqv_clc := EqvClose_i RootContr_clc.

Definition RootContr_clc_bp (R : iterm -> iterm -> Prop) (t1 t2 : iterm) : Prop :=
  RootContr_clc_base R t1 t2 \/
  match t1 with
  | C @i z @i x @i y => R x y /\ y = t2
  | _ => False
  end.

Fixpoint RootContr_clc_plus_n (n : nat) :=
  match n with
  | 0 => RootContr_clc_bp (@eq iterm)
  | S m => RootContr_clc_bp (EqvClose_i (RootContr_clc_plus_n m))
  end.

Definition RootContr_clc_plus x y := exists n, RootContr_clc_plus_n n x y.
Definition Contr_clc_plus := CtxClose_i RootContr_clc_plus.
Definition Red_clc_plus := clos_refl_trans iterm Contr_clc_plus.
Definition Eqv_clc_plus := EqvClose_i RootContr_clc_plus.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.categories.HSET.All.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.Monads.Monads.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.
Require Import algebra.set_algebra.

Local Open Scope container_scope.
Local Open Scope cat.

Section FreeAlgebra.
  Variable (Σ : hit_signature)
           (A : hSet).

  Definition free_point_constr
    : container
    := point_constr Σ ⊕ A.

  Definition free_path_arg
    : container
    := pr12 Σ.

  Definition to_free_point_constr
             {X : hSet}
             (x : W (point_constr Σ) X)
    : W free_point_constr X.
  Proof.
    induction x as [ x | s p IHp ].
    - exact (var x).
    - use sup.
      + exact (inl s).
      + exact IHp.
  Defined.

  Definition free_sig
    : hit_signature.
  Proof.
    use make_hit_signature.
    - exact free_point_constr.
    - exact free_path_arg.
    - exact (λ s, to_free_point_constr (path_lhs Σ s)).
    - exact (λ s, to_free_point_constr (path_rhs Σ s)).
  Defined.

  Definition is_finitary_free_sig
             (HΣ : is_finitary_hit Σ)
    : is_finitary_hit free_sig.
  Proof.
    split.
    - use is_finitary_sum_container.
      + apply HΣ.
      + exact (is_finitary_constant_container A).
    - apply HΣ.
  Qed.

  Section FreeAlgebra.
    Variable (X : hit_algebra free_sig).

    Definition free_carrier
      : hSet
      := pr11 X.

    Definition free_inclusion
               (a : A)
      : free_carrier
      := pr21 X (inr a ,, fromempty).

    Definition free_constr
               (x : ⟦ point_constr Σ ⟧ free_carrier)
      : free_carrier
      := pr21 X (inl (pr1 x) ,, pr2 x).

    Definition free_to_sig_prealgebra
      : hit_prealgebra Σ
      := free_carrier ,, free_constr.

    Definition free_is_hit_algebra_help
               {i : path_index Σ}
               (p : path_arg Σ i → alg_carrier free_to_sig_prealgebra)
               (w : W (point_constr Σ) (path_arg Σ i))
      : sem_endpoint (algebra_map free_to_sig_prealgebra) i p w
        =
        sem_endpoint (algebra_map (pr1 X)) i p (to_free_point_constr w).
    Proof.
      induction w as [ x | s q IHq ].
      - apply idpath.
      - cbn.
        unfold free_constr.
        do 2 apply maponpaths.
        use funextsec.
        intro z ; cbn.
        apply IHq.
    Qed.

    Definition free_is_hit_algebra
      : is_hit_algebra free_to_sig_prealgebra.
    Proof.
      intros i p.
      exact (free_is_hit_algebra_help _ _
             @ pr2 X i p
             @ !(free_is_hit_algebra_help _ _)).
    Qed.

    Definition free_to_sig_algebra
      : hit_algebra Σ.
    Proof.
      simple refine (free_to_sig_prealgebra ,, _).
      exact free_is_hit_algebra.
    Defined.
  End FreeAlgebra.

  Section MakeFreeAlgebra.
    Context (X : hit_algebra Σ)
            (inc : A → alg_carrier (pr1 X)).

    Definition make_free_prealgebra
      : hit_prealgebra free_sig.
    Proof.
      simple refine (_ ,, _) ; simpl.
      - exact (alg_carrier (pr1 X)).
      - intro x.
        induction x as [ s p ].
        induction s as [ s | a ].
        + exact (pr21 X (s ,, p)).
        + exact (inc a).
    Defined.

    Definition make_free_is_hit_algebra_help
               {i : path_index free_sig}
               (p : path_arg free_sig i → alg_carrier make_free_prealgebra)
               (w : W (point_constr Σ) (path_arg Σ i))
      : sem_endpoint
          (algebra_map make_free_prealgebra)
          i p
          (to_free_point_constr w)
        =
        sem_endpoint (algebra_map (pr1 X)) i p w.
    Proof.
      induction w as [ x | s q IHq ].
      - apply idpath.
      - cbn.
        do 2 apply maponpaths.
        use funextsec.
        intro z.
        apply IHq.
    Qed.

    Definition make_free_is_hit_algebra
      : is_hit_algebra make_free_prealgebra.
    Proof.
      intros i p.
      refine (_ @ pr2 X i p @ !_).
      - apply make_free_is_hit_algebra_help.
      - apply make_free_is_hit_algebra_help.
    Qed.

    Definition make_free_algebra
      : hit_algebra free_sig
      := make_free_prealgebra ,, make_free_is_hit_algebra.
  End MakeFreeAlgebra.

  Section FreeMor.
    Context {X Y : hit_algebra free_sig}
            (f : X --> Y).

    Definition free_mor_carrier
      : free_to_sig_algebra X --> free_to_sig_algebra Y.
    Proof.
      simple refine ((pr11 f ,, _) ,, tt) ; simpl.
      abstract
        (use funextsec ;
         intro x;
         induction x as [x y] ;
         exact (eqtohomot (pr21 f) (inl x ,, y))).
    Defined.

    Definition free_mor_inclusion
               (a : A)
      : pr11 free_mor_carrier (free_inclusion X a)
        =
        free_inclusion Y a.
    Proof.
      pose (p := eqtohomot (pr21 f) (inr a ,, fromempty)).
      refine (p @ _) ; cbn ; unfold interpret_container_map ; cbn.
      unfold free_inclusion.
      do 2 apply maponpaths.
      use funextsec.
      intro z.
      induction z.
    Qed.
  End FreeMor.

  Definition make_free_mor
             {X Y : hit_algebra free_sig}
             (f : free_to_sig_algebra X --> free_to_sig_algebra Y)
             (p : ∏ (a : A),
                  pr11 f (free_inclusion X a)
                  =
                  free_inclusion Y a)
    : X --> Y.
  Proof.
    simple refine ((pr11 f ,, _) ,, tt) ; cbn.
    abstract
      (use funextsec ;
       intro x ;
       induction x as [ x y ] ;
       induction x as [ x | a ] ;
       [ exact (eqtohomot (pr21 f) (x ,, y))
       |  refine (_ @ p a @ _) ;
          [ unfold free_inclusion ; cbn ;
            do 3 apply maponpaths ;
            use funextsec ;
            intro z ;
            induction z
        | unfold free_inclusion, interpret_container_map ; cbn ;
          do 2 apply maponpaths ;
          use funextsec ;
          intro z ;
          induction z ]]).
  Defined.
End FreeAlgebra.

(** Free algebra adjunction assuming that initial algebras exist *)
Section FreeAlgebraAdj.
  Context (Σ : hit_signature)
          (free_alg : ∏ (A : hSet),
                      Initial (hit_algebra (free_sig Σ A))).

  Definition free_algebra_functor_obj
             (A : hSet)
    : hit_algebra Σ
    := free_to_sig_algebra _ _ (InitialObject (free_alg A)).

  Definition free_algebra_ump
             {A : hSet}
             (X : hit_algebra Σ)
             (i : A → alg_carrier (pr1 X))
    : free_to_sig_algebra Σ A (free_alg A)
      -->
      free_to_sig_algebra Σ A (make_free_algebra Σ A X i)
    := free_mor_carrier
            _ _
            (InitialArrow (free_alg A) (make_free_algebra _ _ X i)).

  Definition free_algebra_ump_commute
             {A : hSet}
             (X : hit_algebra Σ)
             (i : A → alg_carrier (pr1 X))
             (a : A)
    : pr11 (free_algebra_ump X i) (free_inclusion _ _ _ a) = i a.
  Proof.
    apply free_mor_inclusion.
  Qed.

  Definition free_algebra_ump_eq
             {A : hSet}
             (X : hit_algebra Σ)
             (i : A → alg_carrier (pr1 X))
             (f : free_to_sig_algebra Σ A (free_alg A)
                  -->
                  free_to_sig_algebra Σ A (make_free_algebra Σ A X i))
             (p : ∏ (a : A), pr11 f (free_inclusion _ _ _ a) = i a)
    : free_algebra_ump X i = f.
  Proof.
    pose (InitialArrowUnique
            (free_alg A)
            (make_free_algebra _ _ X i)
            (make_free_mor _ _ f p))
      as q.
    use hit_algebra_map_eq.
    intro x.
    exact (!(maponpaths (λ g, pr11 g x) q)).
  Qed.

  Definition free_algebra_maps_eq
             {A : hSet}
             (X : hit_algebra Σ)
             (i : A → alg_carrier (pr1 X))
             {f g : free_to_sig_algebra Σ A (free_alg A)
                    -->
                    free_to_sig_algebra Σ A (make_free_algebra Σ A X i)}
             (p : ∏ (a : A), pr11 f (free_inclusion _ _ _ a) = i a)
             (q : ∏ (a : A), pr11 g (free_inclusion _ _ _ a) = i a)
    : f = g.
  Proof.
    etrans.
    {
      refine (!_).
      exact (free_algebra_ump_eq X i f p).
    }
    apply free_algebra_ump_eq.
    exact q.
  Qed.

  Definition free_algebra_functor_mor
             {A B : hSet}
             (f : A → B)
    : free_algebra_functor_obj A --> free_algebra_functor_obj B
    := free_algebra_ump
         (free_to_sig_algebra _ _ (free_alg B))
         (λ a, free_inclusion _ _ _ (f a)).

  Definition free_algebra_functor_data
    : functor_data HSET (hit_algebra Σ).
  Proof.
    use make_functor_data.
    - exact free_algebra_functor_obj.
    - exact @free_algebra_functor_mor.
  Defined.

  Definition free_algebra_is_functor
    : is_functor free_algebra_functor_data.
  Proof.
    split.
    - intro X.
      use (free_algebra_ump_eq (free_to_sig_algebra Σ X (free_alg X))).
      intros a ; cbn.
      apply idpath.
    - intros X Y Z f g.
      use (free_algebra_ump_eq (free_to_sig_algebra Σ Z (free_alg Z))).
      intros a ; cbn -[free_algebra_ump] ; unfold free_algebra_functor_mor.
      etrans.
      {
        apply maponpaths.
        apply (free_algebra_ump_commute
                 (free_to_sig_algebra Σ Y (free_alg Y))).
      }
      etrans.
      {
        apply (free_algebra_ump_commute
                 (free_to_sig_algebra Σ Z (free_alg Z))).
      }
      apply idpath.
  Qed.

  Definition free_algebra_functor
    : HSET ⟶ hit_algebra Σ.
  Proof.
    use make_functor.
    - exact free_algebra_functor_data.
    - exact free_algebra_is_functor.
  Defined.

  Definition forgetful_data
    : functor_data (hit_algebra Σ) HSET.
  Proof.
    use make_functor_data.
    - exact (λ X, pr11 X).
    - exact (λ _ _ f, pr11 f).
  Defined.

  Definition forgetful_is_functor
    : is_functor forgetful_data.
  Proof.
    split ; intro ; intros ; apply idpath.
  Qed.

  Definition forgetful
    : hit_algebra Σ ⟶ HSET.
  Proof.
    use make_functor.
    - exact forgetful_data.
    - exact forgetful_is_functor.
  Defined.

  Definition free_algebra_unit_data
    : nat_trans_data
        (functor_identity _)
        (free_algebra_functor ∙ forgetful).
  Proof.
    intros A ; cbn.
    exact (free_inclusion _ _ (free_alg A)).
  Defined.

  Definition free_algebra_unit_is_nat_trans
    : is_nat_trans _ _ free_algebra_unit_data.
  Proof.
    intros A B f.
    use funextsec ; intro a.
    pose (Balg := make_free_algebra
                    _ _
                    (free_to_sig_algebra _ _ (free_alg B))
                    (λ a, free_inclusion _ _ _ (f a))).
    pose (p := free_mor_inclusion _ _ (InitialArrow (free_alg A) Balg) a).
    exact (!p).
  Qed.

  Definition free_algebra_unit
    : functor_identity _ ⟹ free_algebra_functor ∙ forgetful.
  Proof.
    use make_nat_trans.
    - exact free_algebra_unit_data.
    - exact free_algebra_unit_is_nat_trans.
  Defined.

  Definition free_algebra_counit_data
    : nat_trans_data (forgetful ∙ free_algebra_functor) (functor_identity _).
  Proof.
    intros X.
    exact (free_algebra_ump X (λ x, x)).
  Defined.

  Definition free_algebra_counit_is_nat_trans
    : is_nat_trans _ _ free_algebra_counit_data.
  Proof.
    intros X Y f.
    use free_algebra_maps_eq.
    - exact (pr11 f).
    - cbn -[free_algebra_ump].
      intro a.
      unfold free_algebra_functor_mor.
      etrans.
      {
        apply maponpaths.
        apply (free_algebra_ump_commute
                 (free_to_sig_algebra Σ (pr11 Y) (free_alg (pr11 Y)))).
      }
      unfold free_algebra_counit_data.
      etrans.
      {
        apply (free_algebra_ump_commute Y).
      }
      apply idpath.
    - cbn -[free_algebra_ump].
      intros a.
      unfold free_algebra_counit_data.
      etrans.
      {
        apply maponpaths.
        apply (free_algebra_ump_commute X).
      }
      apply idpath.
  Qed.

  Definition free_algebra_counit
    : forgetful ∙ free_algebra_functor ⟹ functor_identity _.
  Proof.
    use make_nat_trans.
    - exact free_algebra_counit_data.
    - exact free_algebra_counit_is_nat_trans.
  Defined.

  Definition free_algebra_form_adjunction
    : form_adjunction
        free_algebra_functor
        forgetful
        free_algebra_unit
        free_algebra_counit.
  Proof.
    split.
    - intros X.
      simpl.
      use (free_algebra_maps_eq (free_algebra_functor_obj X)).
      + apply free_inclusion.
      + cbn -[free_algebra_ump].
        intros x.
        unfold free_algebra_functor_mor.
        etrans.
        {
          apply maponpaths.
          apply (free_algebra_ump_commute
                   (free_to_sig_algebra
                      Σ
                      (free_carrier Σ X (free_alg X))
                      (free_alg (free_carrier Σ X (free_alg X))))).
        }
        unfold free_algebra_counit_data.
        etrans.
        {
          apply (free_algebra_ump_commute (free_algebra_functor_obj X)).
        }
        apply idpath.
      + intros a.
        apply idpath.
    - intros X ; cbn -[free_algebra_ump].
      use funextsec.
      intro x.
      unfold free_algebra_unit_data, free_algebra_counit_data.
      apply free_algebra_ump_commute.
  Qed.

  Definition free_algebra_are_adjoints
    : are_adjoints free_algebra_functor forgetful.
  Proof.
    use make_are_adjoints.
    - exact free_algebra_unit.
    - exact free_algebra_counit.
    - exact free_algebra_form_adjunction.
  Defined.

  Definition free_algebra_monad
    : Monad HSET
    := Monad_from_adjunction free_algebra_are_adjoints.
End FreeAlgebraAdj.


(* -*- mode: coq; mode: visual-line -*-  *)

From HoTT Require Import Basics.
From WildCat Require Import Basics.
From WildCat Require Export Cat0.

Generalizable Variables m n p A B C.

(** * Equivalences of categories *)

Class EssSplit {m A n B} `{IsCat0 m A, HasEquivs n B}
      (F : A -> B) `{!IsFunctor0 F} :=
{
  esssplit_obj : B -> A ;
  esssplit_cate : forall a, F (esssplit_obj a) $<~> a ;
}.

CoInductive IsEquivCat {m A n B} `{IsCat0 m A, HasEquivs n B}
            (F : A -> B) `{!IsFunctor0 F} :=
{
  isequivcat_esssplit : EssSplit F ;
  isequivcat_hom : forall (a b : A),
      @IsEquivCat (pred m) (a $-> b) (pred n) (F a $-> F b)
                  _ _ _ _ _ (fmap F) _;
}.


Set Implicit Arguments.
Require Import List Omega.
Require Export syntax semantics equivalence.

(** * Simple Typing *)

Section Typing.

  Context {X: Const}.

  Definition ctx := list type.

  Implicit Types (s t: exp X) (n m: nat) (Gamma Delta Sigma: ctx)
           (x y: fin) (c d: X) (A B: type)
           (sigma tau: fin -> exp X) (delta xi: fin -> fin).

  Reserved Notation "Gamma ⊢ s : A" (at level 80, s at level 99).

  Inductive typing  Gamma : exp X -> type -> Prop :=
  | typingVar i A: nth Gamma i = Some A -> Gamma ⊢ var i : A
  | typingConst c: Gamma ⊢ const c : ctype X c
  | typingLam s A B: A :: Gamma ⊢ s : B -> Gamma ⊢ lambda s : A → B
  | typingApp s t A B: Gamma ⊢ s : A → B -> Gamma ⊢ t : A -> Gamma ⊢ s t : B
  where "Gamma ⊢ s : A" := (typing Gamma s A).

  Hint Constructors typing.

  Definition typingRen Delta delta Gamma :=
    forall x A, nth Gamma x = Some A -> nth Delta (delta x) = Some A.

  Notation "Delta ⊫ delta : Gamma" := (typingRen Delta delta Gamma) (at level 80, delta at level 99).

  Definition typingSubst Delta sigma Gamma :=
    forall x A, nth Gamma x = Some A -> Delta ⊢ sigma x : A.

  Notation "Delta ⊩ sigma : Gamma" := (typingSubst Delta sigma Gamma) (at level 80, sigma at level 99).

  Lemma typingSubst_cons Delta sigma s Gamma A:
    Delta ⊩ sigma : Gamma -> Delta ⊢ s : A -> Delta ⊩ s .: sigma : A :: Gamma.
  Proof.
    intros ??[|]; cbn; eauto; now intros ? [= ->].
  Qed.

  (** ** Preservation *)
  Section Preservation.
    Lemma preservation_under_renaming delta Gamma Delta s A:
      Gamma ⊢ s : A -> Delta ⊫ delta : Gamma -> Delta ⊢ ren_exp delta s : A.
    Proof.
      induction 1 in  delta, Delta |-*; intros H'; cbn [ren_exp]; eauto.
      econstructor; apply IHtyping.
      intros []; cbn; eauto.
    Qed.

    Lemma preservation_under_substitution sigma Gamma Delta s A:
      Gamma ⊢ s : A -> Delta ⊩ sigma: Gamma -> Delta ⊢ sigma • s : A.
    Proof.
      induction 1 in sigma, Delta |-*; intros H'; cbn [subst_exp]; subst; eauto.
      econstructor; apply IHtyping; intros []; cbn; eauto.
      intros; eapply preservation_under_renaming; eauto.
      intros ?; eauto.
    Qed.

    Lemma preservation_under_reduction s s' Gamma A:
      s > s' -> Gamma ⊢ s : A -> Gamma ⊢ s' : A.
    Proof.
      induction 1 in Gamma, A |-*; intros H1; invp @typing; eauto.
      inv H3. eapply preservation_under_substitution; eauto.
      intros []; cbn; eauto.
      intros ? H; now injection H as ->.
    Qed.

    Lemma preservation_under_steps s s' Gamma A:
      s >* s' -> Gamma ⊢ s : A -> Gamma ⊢ s' : A.
    Proof.
      induction 1 in Gamma, A |-*; eauto using preservation_under_reduction.
    Qed.

  End Preservation.

  Lemma weakening_app Gamma Delta s A:
    Gamma ⊢ s : A -> Gamma ++ Delta ⊢ s : A.
  Proof.
    intros H; replace s with (ren id s) by now asimpl.
    eapply preservation_under_renaming; eauto.
    intros i B H'; unfold id.
    rewrite nth_error_app1; eauto.
    eapply nth_error_Some_lt; eauto.
  Qed.

  Lemma typing_variables Gamma s A:
    Gamma ⊢ s : A -> forall x, x ∈ vars s -> x ∈ dom Gamma.
  Proof.
    intros ? x H1 % vars_varof.
    induction H in x, H1 |-*; inv H1; eauto.
    - now domin H.
    - specialize (IHtyping _ H2).
      eapply dom_lt_iff in IHtyping.
      cbn in *; intuition.
  Qed.

End Typing.

Notation "Gamma ⊢ s : A" := (typing Gamma s A) (at level 80, s at level 99).
Notation "Delta ⊫ delta : Gamma" := (typingRen Delta delta Gamma) (at level 80, delta at level 99).
Notation "Delta ⊩ sigma : Gamma" := (typingSubst Delta sigma Gamma) (at level 80, sigma at level 99).

Hint Constructors typing.
Hint Resolve typing_variables.

Hint Resolve
     preservation_under_renaming
     preservation_under_substitution.


(** * Notation for decidable propositions *)
Require Import Arith.

Definition dec (X : Prop) : Type := {X} + {~ X}.
Class Dec (X : Prop) : Type := decide : dec X.
Arguments decide X {_}.

Ltac gen_Dec_eq := unfold Dec; unfold dec; decide equality.

Instance decide_eq_nat (x y : nat) : Dec (x = y). gen_Dec_eq. Defined.

Instance decide_le_nat (x y : nat) : Dec (x <= y). apply le_dec. Defined.

Instance decide_lt_nat (x y : nat) : Dec (x < y). apply lt_dec. Defined.

Tactic Notation "decide" constr(p) := destruct (decide p).


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat Arith.

Inductive lst : Type := Nil : lst | Cons : nat -> lst -> lst.

Inductive queue : Type := Queue : lst -> lst -> queue.

Fixpoint len (len_arg0 : lst) : nat
           := match len_arg0 with
              | Nil => 0
              | Cons x y => plus 1 (len y)
              end.

Definition qlen (qlen_arg0 : queue) : nat
           := let 'Queue x y := qlen_arg0 in
              plus (len x) (len y).

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Definition amortizeQueue (amortizeQueue_arg0 : lst) (amortizeQueue_arg1 : lst) : queue
           := match amortizeQueue_arg0, amortizeQueue_arg1 with
              | x, y => if leb (len y) (len x) then Queue x y else Queue (append x (rev y)) Nil
              end.

Definition qpush (qpush_arg0 : queue) (qpush_arg1 : nat) : queue
           := match qpush_arg0, qpush_arg1 with
              | Queue x y, n => amortizeQueue x (Cons n y)
              end.

Definition queue_to_lst (queue_to_lst_arg0 : queue) : lst
           := let 'Queue x y := queue_to_lst_arg0 in
              append x (rev y).

Lemma append_nil : forall (l : lst), append l Nil = l.
Proof.
  intros.
  induction l.
  - reflexivity.
  - simpl. rewrite IHl. reflexivity.
Qed.

Theorem theorem0 : forall (q : queue) (n : nat), eq (append (queue_to_lst q) (Cons n Nil)) (queue_to_lst (qpush q n)).
Proof.
  intros.
  destruct q.
  induction l.
  - simpl. rewrite append_nil. reflexivity.
  - simpl. simpl in IHl. rewrite IHl. unfold amortizeQueue. simpl. destruct (len l) eqn:?.
    + simpl. destruct (len l0 <=? 0) eqn:?.
      * simpl. lfind. Admitted.


(**
デカルト閉圏
 *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.

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

Section Categories.

  Class Setoid :=
    {
      carrier : Type;
      equiv : carrier -> carrier -> Prop
    }.
  Coercion carrier : Setoid >-> Sortclass.
  Notation "x === z" := (equiv x z) (at level 70).

  Class Category :=
    {
      (* 対象の定義 *)
      Obj : Type;                           (* Category -> Type *)

      (* 射の定義 *)
      Mor : Obj -> Obj -> Setoid;           (* Coersion が有効になる。 *)

      (* 恒等射の定義 *)
      idC : forall {A : Obj}, Mor A A;

      (* 射の合成の定義 *)
      composeC : forall {A B C : Obj}, Mor B C -> Mor A B -> Mor A C;

      (* 単位律の定義 *)
      left_identity : forall (A B : Obj) (f : Mor A B), composeC idC f === f;
      right_identity : forall (A B : Obj) (f : Mor A B), composeC f idC === f;

      (* 結合律の定義 *)
      associativity : forall (A B C D : Obj)
                             (f : Mor A B) (g : Mor B C) (h : Mor C D),
                        composeC (composeC h g) f === composeC h (composeC g f)
    }.

  Coercion Obj : Category >-> Sortclass.
  Coercion Mor : Category >-> Funclass.

  (* 可換の定義 *)
  Definition commute {CP : Category} {A B C : Obj}
             (f : Mor A B) (g : Mor B C) (h : Mor A C) :=
    composeC g f === h.

  (* 直積 *)
  Class Product {CP : Category} :=
    {
      P : Obj -> Obj -> Obj;
      proj1 : forall {A B : Obj}, Mor (P A B) A;
      proj2 : forall {A B : Obj}, Mor (P A B) B;

      (* 仲介射 *)
      mediating : forall {A B X : Obj}, Mor X A -> Mor X B -> Mor X (P A B);
      (* mediating = (&&&) *)

      (* commute CP のCPは、Section Commutativity の Cat に渡される。 *)
      med_commute1 : forall (A B X : Obj) (f : Mor X A) (g : Mor X B),
          commute (mediating f g) proj1 f;
      med_commute2 : forall (A B X : Obj) (f : Mor X A) (g : Mor X B),
          commute (mediating f g) proj2 g;
      med_unique : forall (A B X : Obj)
                          (f : Mor X A) (g : Mor X B) (h : Mor X (P A B)),
          commute h proj1 f -> commute h proj2 g -> h === mediating f g
    }.

  Class Cartesian_Closed {CCC : Category} {CP : Product} :=
    {
      Exp : Obj -> Obj -> Obj;
      eval  : forall {X Y Z : Obj}, Mor (P (Exp Y X) Z) Y;
      f     : forall {X Y Z : Obj}, Mor (P X Z) Y;
      curry : forall {X Y Z : Obj}, Mor (P X Z) Y -> Mor X (Exp Y X)
    }.
End Categories.

(**
この世で一番簡単なデカルト閉圏
キメラ 2011-01-31
 *)
Section SimplCCC.

  Instance EqMor : forall (A B : bool), Setoid :=
    {
      carrier := bool -> bool;
      equiv := @eqfun bool bool
    }.

  Instance Func : Category :=               (* Category *)
    {
      Obj := bool;
      Mor := EqMor;
      idC A := id;
      composeC A B C := funcomp tt          (* compose *)
    }.
  Proof.
    - by [].
    - by [].
    - by [].
  Defined.

  Instance Prod : Product :=
    {
      P := andb;                            (* && *)
      proj1 A B := id;                      (* XXXX *)
      proj2 A B := id;                      (* XXXX *)
      mediating A B X :=
        fun (f g : bool -> bool) (x : bool) => f x && g x
    }.
  Proof.
    - admit.
    - admit.
    - admit.
  Qed.

  Compute false ==> false.                  (* true *)
  Compute true ==> false.                   (* false *)
  Compute false ==> true.                   (* true *)
  Compute true ==> true.                    (* true *)
  Instance CCC : Cartesian_Closed :=
    {
      Exp := implb                          (* ==> *)
    }.

End SimplCCC.

(* 未完 *)


(** The order [lt] on [T] is not well-founded *)

From hydras Require Import T1.
From Coq Require Import Relations.

Section Proof_of_lt_not_wf.

  Hypothesis lt_wf : well_founded lt.

  Fixpoint  s (i:nat) : T1 :=
    match i with
      0 => phi0 2
    | S j => cons 1 0 (s j)
    end.

  Lemma s_decr : forall i,  lt (s (S i)) (s i).
  Proof.
    induction i.
      compute; auto.
      cbn;  apply tail_lt; apply IHi.
  Qed.

  (* From [coq-art] exercises *)

  Section seq_intro.
    Variable A: Type.
    Variable seq : nat -> A.
    Variable R : A -> A -> Prop.
    Hypothesis Rwf : well_founded R.
    Let is_in_seq (x:A) :=  exists i : nat, x = seq i.

    Lemma not_acc : forall a b:A, R a b -> ~ Acc R a -> ~ Acc R b.
    Proof.
      intros a b H H0 H1;  absurd (Acc R a); auto.
    Qed.

    Lemma acc_imp : forall a b:A, R a b -> Acc R b -> Acc R a.
    Proof.
      intros a b H H0;  generalize a H; now induction H0.
    Qed.

    Lemma not_decreasing_aux : ~ (forall n:nat, R (seq (S n)) (seq n)).
    Proof.
      unfold not in |- *; intro Hseq.
      assert  (H : forall a:A, is_in_seq a -> ~ Acc R a).
      -   intro a; pattern a in |- *; apply well_founded_ind with A R; auto.
          intros x Hx [i Hi]; generalize (Hseq i); intro H0; rewrite Hi.
          apply not_acc with (seq (S i)); auto.
          apply Hx.
          +  rewrite Hi; auto.
          +  exists (S i); auto.
      - apply (H (seq 0)).
        +  exists 0; trivial.
        + apply Rwf.
    Qed.

  End seq_intro.

  Theorem not_decreasing (A:Type)(R: relation A) (Hwf : well_founded R) :
    ~ (exists seq : nat -> A, (forall i:nat, R (seq (S i)) (seq i))).
  Proof.
    intros [s Hs].  apply (not_decreasing_aux _ s R Hwf Hs).
  Qed.

  Lemma contrad : False.
    apply (not_decreasing T1 lt lt_wf).  exists s.
    apply  s_decr.
  Qed.

End Proof_of_lt_not_wf.

Lemma lt_not_wf : ~ well_founded lt.
  exact contrad.
Qed.


From Undecidability.L Require Export Datatypes.LBool Datatypes.LNat Datatypes.LTerm.
Require Import Nat.
From Undecidability.L Require Import Tactics.LTactics Functions.EqBool.
Import EqBool.
(* * Extracted Functions *)

(* ** Extracted equality of encoded terms *)

Fixpoint term_eqb s t :=
  match s,t with
  | var n, var m => eqb n m
  | L.app s1 t1, L.app s2 t2 => andb (term_eqb s1 s2) (term_eqb t1 t2)
  | lam s',lam t' => term_eqb s' t'
  | _,_ => false
  end.

Lemma term_eqb_spec : forall x y1 : term, reflect (x = y1) (term_eqb x y1).
Proof with try (constructor;congruence).
  induction x;cbn; destruct y1...
  - destruct (eqb_spec n n0)...
  -destruct (IHx1 y1_1)...
   destruct (IHx2 y1_2)...
  -destruct (IHx y1)...
Qed.

#[global]
Instance eqbTerm : eqbClass term_eqb.
Proof.
  exact term_eqb_spec.
Qed.

Global
Instance eqbComp_nat : eqbCompT term.
Proof.
  evar (c:nat). exists c. unfold term_eqb.
  unfold enc;cbn. unfold term_enc.
  extract. unfold eqb,eqbTime.
  [c]:exact (5 + c__eqbComp nat).
  all:unfold c. set (c__eqbComp nat). change (LNat.nat_enc) with (enc (X:=nat)).
  solverec. all:try nia.
Qed.


Require Import Coq.Classes.RelationClasses.
Notation iffT A B := (((A -> B) * (B -> A)))%type.
Notation iffTp := (fun A B => inhabited (iffT A B)).

Global Instance iffTp_Reflexive : Reflexive iffTp | 1.
Proof. repeat constructor; intro; assumption. Defined.
Global Instance iffTp_Symmetric : Symmetric iffTp | 1.
Proof. repeat (intros [?] || intro); constructor; tauto. Defined.
Global Instance iffTp_Transitive : Transitive iffTp | 1.
Proof. repeat (intros [?] || intro); constructor; tauto. Defined.