(* string requirements *)
Require Import Strings.String.
Local Open Scope string_scope.
Scheme Equality for string.
Require Import Ascii.

(* integral requirements *)
Require Import Coq.ZArith.BinInt.
Local Open Scope Z_scope.

(* requirements for cases and arrays *)
Local Open Scope list_scope.

Inductive ErrorZ : Type := (* variabila int = NUMBR *)
| error_Z : ErrorZ
| number : Z -> ErrorZ.
Coercion number : Z >-> ErrorZ.

Inductive ErrorBool : Type := (* variabila bool = TROOF *)
| error_bool : ErrorBool
| boolean : bool -> ErrorBool.
Coercion boolean : bool >-> ErrorBool.

Inductive ErrorString : Type := (* variabila string = YARN *)
| error_string : ErrorString
| vstring : string -> ErrorString.
Coercion vstring : string >-> ErrorString.

Inductive realVar :=
| var_notdecl : realVar
| error_equal : realVar
| default : realVar
| numbr_e : ErrorZ -> realVar
| troof_e : ErrorBool -> realVar
| strng_e : ErrorString -> realVar.

Check numbr_e. Check ErrorZ.

Scheme Equality for realVar.

Definition Env := string -> realVar.
Definition env_notdecl : Env :=
    fun v => var_notdecl.

Definition CheckVar (a : realVar) (b : realVar) : bool := (* se verifica daca acea variabila exista *)
  match a with
  | var_notdecl => match b with
                   | var_notdecl => true
                   | _ => false
                   end
  | error_equal => match b with
                   | error_equal => true
                   | _ => false
                   end
  | numbr_e n1 => match b with
                   | numbr_e n2 => true
                   | _ => false
                   end
  | troof_e b1 => match b with
                   | troof_e b2 => true
                   | _ => false
                   end
  | strng_e s1 => match b with
                   | strng_e s2 => true
                   | _ => false
                   end
  | default => match b with
                   | default => true
                   | _ => false
                   end
end.

Definition update (env : Env) (s : string) (x : realVar) : Env :=
  fun y => if (string_beq y s)
              then
              if (andb (CheckVar (var_notdecl) (env y)) (negb(CheckVar (default) (x))))
              then var_notdecl
              else
                if (andb (CheckVar (var_notdecl) (env y)) (CheckVar (default) (x)))
                then default
                else
                  if (orb (CheckVar (default) (env y)) (CheckVar (x) (env y)))
                  then x
                  else error_equal
            else env y.

(* string expressions *)
Inductive StExp :=
| sconstant : ErrorString -> StExp
| sident : string -> StExp
| sconcat : StExp -> StExp -> StExp.

Coercion sconstant : ErrorString >-> StExp.

Definition convert_string (s: ErrorString) : string :=
  match s with
  | error_string => ""
  | vstring s' => s'
  end.

Notation "'CONCAT' a 'WIT' b" := (sconcat a b) (at level 50).

(* Check length(convert_string "long"). *)

Definition err_cat (s1 s2 : ErrorString) : ErrorString :=
  match s1, s2 with
  | error_string, _ => error_string
  | _, error_string => error_string
  | vstring s1, vstring s2 => vstring (s1 ++ s2)
  end.

(* Big-Step semantics for string expressions *)
Reserved Notation "st -[ S ]-> st'" (at level 50).
Inductive stringBS : StExp -> Env -> ErrorString -> Prop :=
| sconstantBS : forall s sg, sconstant s -[ sg ]-> s
| sidentBS : forall sid sg, sident sid -[ sg ]-> match (sg sid) with
                                              | strng_e sid => sid
                                              | _ => ""
                                              end
| scatBS : forall s1 s2 r i1 i2 sg,
    s1 -[ sg ]-> i1 ->
    s2 -[ sg ]-> i2 ->
    r = err_cat i1 i2 ->
    sconcat s1 s2 -[ sg ]-> r
where "st -[ S ]-> st'" := (stringBS st S st').

Inductive AExp :=
(* arithmetic expressions *)
| aconstant : ErrorZ -> AExp
| aident : string -> AExp
| plus : AExp -> AExp -> AExp
| minus : AExp -> AExp -> AExp
| multiply : AExp -> AExp -> AExp
| divide : AExp -> AExp -> AExp
| modulo : AExp -> AExp -> AExp
| increment : AExp -> AExp
| decrement : AExp -> AExp
| maximum : AExp -> AExp -> AExp
| minimum : AExp -> AExp -> AExp
| swap : AExp -> AExp -> AExp
| len : StExp -> AExp.

Coercion aconstant : ErrorZ >-> AExp.
Coercion aident : string >-> AExp.

(* notations for arithmetic expressions*)
Notation "'SUM' 'OF' a 'AN' b" := (plus a b) (at level 20).
Notation "'DIFF' 'OF' a 'AN' b" := (minus a b) (at level 20).
Notation "'PRODUKT' 'OF' a 'AN' b" := (multiply a b) (at level 24).
Notation "'QUOSHUNT' 'OF' a 'AN' b" := (divide a b) (at level 24).
Notation "'MOD' 'OF' a 'AN' b" := (modulo a b) (at level 24).
Notation "'BIGGR' 'OF' a 'AN' b" := (maximum a b) (at level 40).
Notation "'SMALLR' 'OF' a 'AN' b" := (minimum a b) (at level 40).
Notation "'BUFF' n" := (increment n) (at level 20).
Notation "'NERF' n" := (decrement n) (at level 20).
Notation "'FWAP' a 'WIT' b" := (swap a b) (at level 45).
Notation "'LANG' 'OF' a" := (len a) (at level 46).

Check (SUM OF 3 AN 4).
Check (DIFF OF "a" AN 2).
Check (BUFF 15).
Check (NERF "i").
Check (LANG OF "b").

(* simulating arithmetic calculus errors *)
Definition plus_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | number n1 , number n2 => number (n1 + n2)
  end.

Definition minus_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | number n1 , number n2 => if Z.ltb n1 n2
                       then error_Z
                       else number (n1 - n2)
  end.

Definition multiply_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | number n1 , number n2 => number (n1 * n2)
  end.

Definition divide_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | _, number 0 => error_Z
  | number n1 , number n2 => number (Z.div n1 n2)
  end.

Definition modulo_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | _, number 0 => error_Z
  | number n1 , number n2 => number (Z.modulo n1 n2)
  end.

Definition incr_err (n : ErrorZ) : ErrorZ :=
  match n with
  | error_Z => error_Z
  | number n => number (n + 1)
  end.

Definition decr_err (n : ErrorZ) : ErrorZ :=
  match n with
  | error_Z => error_Z
  | number n => number (n - 1)
  end.

Definition max_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | number n1 , number n2 => if Z.ltb n1 n2
                       then n2
                       else n1
  end.

Definition min_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | number n1 , number n2 => if Z.ltb n1 n2
                       then n1
                       else n2
  end.

(* Definition swap_err (n1 n2 : ErrorZ) : ErrorZ :=
  match n1, n2 with
  | error_Z, _ => error_Z
  | _, error_Z => error_Z
  | number n1 , number n2 => match n1, n2 with
                             | number n1 => n2
                             | number n2 => n1
                             end
  end.

  aici n-am inteles cum sa-l implementez *)

(* Big-Step semantics for arithmetic expressions *)
Reserved Notation "A =[ S ]=> N" (at level 60).
Inductive aritBS : AExp -> Env -> ErrorZ -> Prop :=
| constantBS : forall n sg, aconstant n =[ sg ]=> n
| identBS : forall aid sg, aident aid =[ sg ]=> match (sg aid) with
                                              | numbr_e aid => aid
                                              | _ => error_Z
                                              end
| plusBS : forall a1 a2 i1 i2 sg n,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    n = plus_err i1 i2 ->
    plus a1 a2 =[ sg ]=> n
| minusBS : forall a1 a2 i1 i2 sg n,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    n = minus_err i1 i2 ->
    minus a1 a2 =[ sg ]=> n
| multBS : forall a1 a2 i1 i2 sg n,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    n = multiply_err i1 i2 ->
    multiply a1 a2 =[ sg ]=> n
| divBS : forall a1 a2 i1 i2 sg n,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    n = divide_err i1 i2 ->
    divide a1 a2 =[ sg ]=> n
| modBS : forall a1 a2 i1 i2 sg n,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    n = modulo_err i1 i2 ->
    modulo a1 a2 =[ sg ]=> n
| incrBS : forall a i sg n,
    a =[ sg ]=> i ->
    n = incr_err i ->
    increment a =[ sg ]=> n
| decrBS : forall a i sg n,
    a =[ sg ]=> i ->
    n = decr_err i ->
    decrement a =[ sg ]=> n
| maxBS : forall a1 a2 i1 i2 sg b,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    b = max_err i1 i2 ->
    maximum a1 a2 =[ sg ]=> b
| minBS : forall a1 a2 i1 i2 sg b,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    b = min_err i1 i2 ->
    minimum a1 a2 =[ sg ]=> b
(* | lenBS : forall s i sg r,
    s -[ sg ]-> i ->
    r = numbr_e (length (convert_string s)) ->
    len s =[ sg ]=> r *)
(* | swapBS : forall a1 a2 i1 i2 aux sg,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    aux = i1 ->
    a1 = i2 ->
    a2 = aux ->
    swap a1 a2 =[ sg ]=> *)
where "a =[ sg ]=> n" := (aritBS a sg n).

Compute (env_notdecl "a").
Example ex1 : SUM OF 3 AN 4 =[ env_notdecl ]=> 7.
Proof.
  eapply plusBS.
  eapply constantBS.
  eapply constantBS.
  simpl. reflexivity.
Qed.

Example ex1' : DIFF OF 3 AN 5 =[ env_notdecl]=> error_Z.
Proof.
  eapply minusBS.
  eapply constantBS.
  eapply constantBS.
  simpl. reflexivity.
Qed.

Example ex2 : MOD OF 12 AN 0 =[ env_notdecl ]=> error_Z.
Proof.
  eapply modBS.
  eapply constantBS.
  eapply constantBS.
  simpl. reflexivity.
Qed.

Example ex3 : BUFF 10 =[ env_notdecl ]=> 11.
Proof.
  eapply incrBS.
  eapply constantBS.
  simpl. reflexivity.
Qed.

Example ex4 : BIGGR OF 8 AN 5 =[ env_notdecl ]=> 8.
Proof.
  eapply maxBS.
  eapply constantBS.
  eapply constantBS.
  simpl. reflexivity.
Qed.

(* boolean expressions *)
Inductive BExp :=
| bconstant : ErrorBool -> BExp
| bident : string -> BExp
| right : BExp
| wrong : BExp
| non : BExp -> BExp
| and : BExp -> BExp -> BExp
| or : BExp -> BExp -> BExp
| xor : BExp -> BExp -> BExp
| same : AExp -> AExp -> BExp
| diff : AExp -> AExp -> BExp
| lt : AExp -> AExp -> BExp
| gt : AExp -> AExp -> BExp
| leq : AExp -> AExp -> BExp
| geq : AExp -> AExp -> BExp
| scomp : StExp -> StExp -> BExp.

Coercion bconstant : ErrorBool >-> BExp.
Coercion bident : string >-> BExp.

(* notations for boolean expressions *)
Notation "'BOTH' 'OF' a 'AN' b" := (and a b) (at level 49).
Notation "'EITHER' 'OF' a 'AN' b" := (or a b) (at level 49).
Notation "'WON' 'OF' a 'AN' b" := (xor a b) (at level 49).
Notation "'NOT' n" := (non n) (at level 49).
Notation "'BOTH' 'SAEM' a 'AN' b" := (same a b) (at level 49).
Notation "'DIFFRINT' a 'AN' b" := (diff a b) (at level 49).
Notation "'DIFFRINT' 'AN' 'BIGGR' 'OF' a 'AN' b" := (lt a b) (at level 53).
Notation "'DIFFRINT' 'AN' 'SMALLR' 'OF' a 'AN' b" := (gt a b) (at level 53).
Notation "'BOTH' 'SAEM' 'AN' 'BIGGR' 'OF' a 'AN' b" := (geq a b) (at level 53).
Notation "'BOTH' 'SAEM' 'AN' 'SMALLR' 'OF' a 'AN' b" := (leq a b) (at level 53).
Notation "'COMP' a 'WIT' b" := (scomp a b)(at level 50).

Check (NOT "x").
Check (NOT true).
Check (BOTH SAEM "a" AN BIGGR OF "a" AN "b").
Check (COMP "a" WIT "x").

Definition non_err (n : ErrorBool) : ErrorBool :=
  match n with
  | error_bool => error_bool
  | boolean n => negb (n)
  end.

Definition and_err (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
  | error_bool, _ => error_bool
  | _, error_bool => error_bool
  | boolean n1 , boolean n2 => boolean (andb n1 n2)
  end.

Definition or_err (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
  | error_bool, _ => error_bool
  | _, error_bool => error_bool
  | boolean n1 , boolean n2 => boolean (orb n1 n2)
  end.

Definition xor_err (n1 n2 : ErrorBool) : ErrorBool :=
  match n1, n2 with
  | error_bool, _ => error_bool
  | _, error_bool => error_bool
  | boolean n1 , boolean n2 => boolean (xorb n1 n2)
  end.

Definition same_err (n1 n2 : ErrorZ) : ErrorBool :=
  match n1, n2 with
  | error_Z, _ => error_bool
  | _, error_Z => error_bool
  | number n1 , number n2 => boolean (Z.eqb n1 n2)
  end.

Definition diff_err (n1 n2 : ErrorZ) : ErrorBool :=
  match n1, n2 with
  | error_Z, _ => error_bool
  | _, error_Z => error_bool
  | number n1 , number n2 => boolean (negb(Z.eqb n1 n2))
  end.

Definition lt_err (n1 n2 : ErrorZ) : ErrorBool :=
  match n1, n2 with
  | error_Z, _ => error_bool
  | _, error_Z => error_bool
  | number n1 , number n2 => boolean (Z.ltb n1 n2)
  end.

Definition gt_err (n1 n2 : ErrorZ) : ErrorBool :=
  match n1, n2 with
  | error_Z, _ => error_bool
  | _, error_Z => error_bool
  | number n1 , number n2 => boolean (Z.ltb n2 n1)
  end.

Definition leq_err (n1 n2 : ErrorZ) : ErrorBool :=
  match n1, n2 with
  | error_Z, _ => error_bool
  | _, error_Z => error_bool
  | number n1 , number n2 => boolean (Z.leb n1 n2)
  end.

Definition geq_err (n1 n2 : ErrorZ) : ErrorBool :=
  match n1, n2 with
  | error_Z, _ => error_bool
  | _, error_Z => error_bool
  | number n1 , number n2 => boolean (Z.leb n2 n1)
  end.

Definition equal_strings (s1 s2 : string ) : bool :=
  if(string_dec s1 s2)
  then true
  else false. (* folosit pentru egalitatea a doua stringuri *)

Definition scmp (s1 s2 : ErrorString) : ErrorBool :=
  match s1, s2 with
  | error_string, _ => error_bool
  | _, error_string => error_bool
  | vstring s1 , vstring s2 => equal_strings (convert_string s1) (convert_string s2)
  end.

(* Big-Step semantics for boolean expressions - in works *)
Reserved Notation "B ={ S }=> B'" (at level 70).
Inductive boolBS : BExp -> Env -> ErrorBool -> Prop :=
| itz_tru : forall sg, right ={ sg }=> true
| itz_fls : forall sg, wrong ={ sg }=> false
| bconstantBS : forall b sg, bconstant b ={ sg }=> b
| bidentBS : forall bid sg, bident bid ={ sg }=> match (sg bid) with
                                              | troof_e bid => bid
                                              | _ => false
                                              end
(* | ttof : forall b sg,
    b ={ sg }=> true ->
    non b ={ sg }=> false
| ftot : forall b sg,
    b ={ sg }=> false ->
    non b ={ sg }=> true *)
| notBS : forall sg b b' i1,
    b ={ sg }=> i1 ->
    b' = (non_err i1) ->
    (non b) ={ sg }=> b'
(* | tand : forall b1 b2 sg r,
    b1 ={ sg }=> true ->
    b2 ={ sg }=> r ->
    and b1 b2 ={ sg }=> r
| fand : forall b1 b2 sg,
    b1 ={ sg }=> false ->
    and b1 b2 ={ sg }=> false *)
| andBS : forall sg b1 b2 i1 i2 b,
    b1 ={ sg }=> i1 ->
    b2 ={ sg }=> i2 ->
    b = (and_err i1 i2) ->
    and b1 b2 ={ sg }=> b
(* | tor : forall b1 b2 sg,
    b1 ={ sg }=> true ->
    or b1 b2 ={ sg }=> true
| wfor : forall b1 b2 sg r,
    b1 ={ sg }=> false ->
    b2 ={ sg }=> r ->
    or b1 b2 ={ sg }=> r *)
| orBS : forall sg b1 b2 i1 i2 b,
    b1 ={ sg }=> i1 ->
    b2 ={ sg }=> i2 ->
    b = (or_err i1 i2) ->
    or b1 b2 ={ sg }=> b
(* | fxor : forall b1 b2 sg r,
    b1 ={ sg }=> r ->
    b2 ={ sg }=> r ->
    xor b1 b2 ={ sg }=> false
| txor : forall b1 b2 sg r1 r2,
    b1 ={ sg }=> r1 ->
    b2 ={ sg }=> r2 ->
    xor b1 b2 ={ sg }=> true  *)
| xorBS : forall sg b1 b2 i1 i2 b,
    b1 ={ sg }=> i1 ->
    b2 ={ sg }=> i2 ->
    b = (xor_err i1 i2) ->
    xor b1 b2 ={ sg }=> b
| sameBS : forall sg b1 b2 i1 i2 b,
    b1 =[ sg ]=> i1 ->
    b2 =[ sg ]=> i2 ->
    b = (same_err i1 i2) ->
    same b1 b2 ={ sg }=> b
| diffBS : forall sg b1 b2 i1 i2 b,
    b1 =[ sg ]=> i1 ->
    b2 =[ sg ]=> i2 ->
    b = (diff_err i1 i2) ->
    diff b1 b2 ={ sg }=> b
| lessthanBS : forall a1 a2 i1 i2 sg r,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    r = lt_err i1 i2 ->
    lt a1 a2 ={ sg }=> r
| greaterthanBS : forall a1 a2 i1 i2 sg r,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    r = gt_err i1 i2 ->
    gt a1 a2 ={ sg }=> r
| lesseqBS : forall a1 a2 i1 i2 sg r,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    r = leq_err i1 i2 ->
    leq a1 a2 ={ sg }=> r
| greatereqBS : forall a1 a2 i1 i2 sg r,
    a1 =[ sg ]=> i1 ->
    a2 =[ sg ]=> i2 ->
    r = geq_err i1 i2 ->
    geq a1 a2 ={ sg }=> r
| cmpBS : forall s1 s2 i1 i2 sg r,
    s1 -[ sg ]-> i1 ->
    s2 -[ sg ]-> i2 ->
    r = scmp i1 i2 ->
    scomp s1 s2 ={ sg }=> r
where "B ={ S }=> B'" := (boolBS B S B').

Example ex5 : NOT true ={ env_notdecl }=> false.
Proof.
  eapply notBS.
  eapply bconstantBS.
  simpl. reflexivity.
Qed.

Example ex6 : BOTH OF true AN false ={ env_notdecl }=> false.
Proof.
  eapply andBS.
  eapply bconstantBS.
  eapply bconstantBS.
  simpl. reflexivity.
Qed.

Example ex7 : DIFFRINT AN BIGGR OF 7 AN 10 ={ env_notdecl }=> true.
Proof.
  eapply lessthanBS.
  eapply constantBS.
  eapply constantBS.
  simpl. reflexivity.
Qed.

Example ex8 : COMP "sb" WIT "tf" ={ env_notdecl }=> true.
Proof.
  eapply cmpBS.
  eapply sconstantBS.
  eapply sconstantBS.
  simpl.
Abort.

Inductive VExp :=
| error_vector : VExp
| vector_int : Z -> list Z -> VExp.

(* flow controls + assignment + sequence *)
Inductive Stmt :=
| equals_Z : string -> AExp -> Stmt
| equals_bool : string -> BExp -> Stmt
| equals_string : string -> StExp -> Stmt
| equalsvect_Z: string -> VExp -> Stmt
| decl_vectZ : string -> VExp -> Stmt
| decl_Z : string -> Stmt
| decl_bool : string -> Stmt
| decl_string : string -> Stmt
| seqinflow : Stmt -> Stmt -> Stmt
| ifthen : BExp -> Stmt -> Stmt
| ifthenelse : BExp -> Stmt -> Stmt -> Stmt
| whileseq : BExp -> Stmt -> Stmt
| forsq_any : Stmt -> Stmt -> BExp -> Stmt -> Stmt
| break : Stmt
| continue : Stmt
| comment : string -> Stmt
| switch : AExp -> list Cases -> Stmt
with Cases :=
    | case_nr : AExp -> Stmt -> Cases
    | default_case : Stmt -> Cases.

(* notations for flow controls *)
Notation "a 'AND' b" := (seqinflow a b)(at level 90). (*pentru secventele folosite in partea de conditional*)
Notation "a ; b" := (seqinflow a b) (at level 90).
Notation "'BTW' comm" := (comment comm) (at level 90).
Notation "'OBTW' comm 'TLDR'" := (comment comm) (at level 90).

Notation " a 'ITZ' b" := (equals_Z a b) (at level 50).
Notation " a 'ITZB' b" := (equals_bool a b) (at level 50).
Notation " a 'ITS' b" := (equals_string a b) (at level 50).
Notation " 'I' 'HAS' 'A' 'ANUMBR' a [ n ] " := (decl_vectZ a (vector_int n nil)) (at level 80).
Notation " 'I' 'HAS' 'A' 'NUMBR' a" := (decl_Z a) (at level 80).
Notation " 'I' 'HAS' 'A' 'TROOF' a" := (decl_bool a) (at level 80).
Notation " 'I' 'HAS' 'A' 'YARN' a" := (decl_string a) (at level 80).

Notation " cond 'O_RLY?' 'YA_RLY' { s1 } 'NO_WAI' { s2 } 'OIC'" := (ifthenelse cond s1 s2) (at level 95).
Notation " cond 'O_RLY?' 'YA_RLY' { s } 'OIC'" := (ifthen cond s) (at level 95).
Notation " 'IM_IN_YR_WHILE' cond s 'IM_OUTTA_YR_WHILE'" := (whileseq cond s) (at level 95).
Notation " 'IM_IN_YR_LOOP' oper 'YR' a 'WILE' cond { s } 'IM_OUTTA_YR_LOOP'" := (forsq_any oper a cond s) (at level 95).
Notation "'ENUF'" := (break) (at level 80).
Notation "'GOON'" := (continue) (at level 80).

Check (I HAS A NUMBR "a" ; "a" ITZ 12).
Check (I HAS A ANUMBR "a" [30]).
Check (I HAS A TROOF "b" ; "b" ITZB false).
Check ( "c" ITS "ff").

(* notatii pentru functia switch() *)
Notation "var ',WTF?' C1 ;; C2 ;; .. ;; Cn 'OIC'" := (switch var (cons C1 (cons C2 .. (cons Cn nil) .. ))) (at level 99).
Notation "'OMG' val { seq }" := (case_nr val seq) (at level 99).
Notation "'OMGWTF' { seq }" := (default_case seq) (at level 99).

(* input-output functions *)
Inductive InAndOut :=
| scan : string -> InAndOut
| write : string -> InAndOut.

Notation "'GIMMEH' var" := (scan var)(at level 91).
Notation "'VISIBLE' var" := (write var)(at level 91).

Reserved Notation "S -{ sg }-> sg'" (at level 75).
Inductive strBS : Stmt -> Env -> Env -> Prop :=
| decl_ZBS : forall i x sg sg',
    sg' = (update sg x (numbr_e i)) ->
    decl_Z x -{ sg }-> sg'
| decl_BoolBS : forall i x sg sg',
    sg' = (update sg x (troof_e i)) ->
    decl_bool x -{ sg }-> sg'
| decl_StringBS : forall i x sg sg',
    sg' = (update sg x (strng_e i)) ->
    decl_string x -{ sg }-> sg'
| equal_ZBS : forall a i x sg sg',
    a =[ sg ]=> i ->
    sg' = (update sg x (numbr_e i)) ->
    equals_Z x a -{ sg }-> sg'
| equal_boolBS : forall a i x sg sg',
    a ={ sg }=> i ->
    sg' = (update sg x (troof_e i)) ->
    equals_bool x a -{ sg }-> sg'
| equal_stringBS : forall a i x sg sg',
    sg' = (update sg x (strng_e i)) ->
    equals_string x a -{ sg }-> sg'
| seqBS : forall s1 s2 sg sg1 sg2,
    s1 -{ sg }-> sg1 ->
    s2 -{ sg1 }-> sg2 ->
    seqinflow s1 s2 -{ sg }-> sg2
| ifelse_falseBS : forall cond s1 s2 sg sg',
    cond ={ sg }=> false ->
    s2 -{ sg }-> sg' ->
    ifthenelse cond s1 s2 -{ sg }-> sg'
| ifelse_trueBS : forall cond s1 s2 sg sg',
    cond ={ sg }=> true ->
    s1 -{ sg }-> sg' ->
    ifthenelse cond s1 s2 -{ sg }-> sg'
| iftrueBS : forall cond s sg sg',
    cond ={ sg }=> true ->
    s -{ sg }-> sg' ->
    ifthen cond s -{ sg }-> sg'
| iffalseBS : forall cond s sg sg',
    cond ={ sg }=> false ->
    ifthen cond s -{ sg }-> sg'
| whilefalseBS : forall b s sg,
    b ={ sg }=> false ->
    whileseq b s -{ sg }-> sg
| whiletrueBS : forall b s sg sg',
    b ={ sg }=> true ->
    (s ; whileseq b s) -{ sg }-> sg' ->
    whileseq b s -{ sg }-> sg'
| forany_trueBS : forall init cond op s sg sg',
    cond ={ sg }=> true ->
    ( init ; whileseq cond (s ; op) ) -{ sg }-> sg' ->
    forsq_any op init cond s -{ sg }-> sg'
| forany_falseBS : forall init cond op s sg sg',
    cond ={ sg }=> false ->
    forsq_any op init cond s -{ sg }-> sg'
| breakBS : forall s sg,
    s -{ sg }-> sg
| continueBS : forall s sg sg',
    s -{ sg }-> sg'
| switchBS : forall a i case b s sg sg',
    a =[ sg ]=> i ->
    b = same i case ->
    switch a s -{ sg }-> sg'
where "s -{ sg }-> sg'" := (strBS s sg sg').

Check (SUM OF "VAR" AN 1).

Check(same "ANIMAL" "CAT")
  O_RLY?
    YA_RLY
    { "CAT" ITS "ok" }
  OIC.

Check I HAS A NUMBR "A"; "A" ITZ 0 ;
  whileseq (BOTH SAEM "A" AN 8)
  ("A" ITZ SUM OF "A" AN 2 ) .

Check I HAS A NUMBR "B" ; "B" ITZ 1 ;
  forsq_any ("i" ITZ SUM OF "i" AN 1) ("i" ITZ 1) (NOT BOTH SAEM "i" AN 4)
  ("B" ITZ PRODUKT OF "B" AN 2).

Check BTW "notatie".
Check OBTW "alta notatie" TLDR.

(* Check switch "var"
      case_nr 3 "a" ITZ 0
      case_nr 2 "a" ITZ 1
      .
 *)

Compute (I HAS A NUMBR "n" ; "n" ITZ 4).

Example ex8 : exists sg', ("n" ITZ 4 ; "n" ITZ 9) -{ env_notdecl }-> sg' /\ sg' "n" = numbr_e 9.
Proof.
  eexists.
  split.
  - eapply seqBS.
    eapply equal_ZBS. eapply constantBS. reflexivity.
    eapply equal_ZBS. eapply constantBS. reflexivity.
  - unfold update. simpl. (* reflexivity. *)
Admitted.

Definition p1 := I HAS A NUMBR "x";
                "x" ITZ 5;
                whileseq (NOT BOTH SAEM "x" AN 10)
                ("x" ITZ SUM OF "x" AN 1).

Example ex9 : exists sg', p1 -{ env_notdecl }-> sg' /\ sg' "x" = numbr_e 10.
Proof.
  eexists.
  split.
  unfold p1.
  eapply seqBS. eapply seqBS.
  eapply decl_ZBS. eauto.
  eapply equal_ZBS. eapply constantBS. reflexivity.
  eapply whiletrueBS. eapply notBS. eapply sameBS. eapply identBS. eapply constantBS.
  unfold update. simpl. reflexivity. simpl. (* eauto. *)
Admitted.

Definition p2 :=  I HAS A NUMBR "x";
                  "x" ITZ 1;
                  forsq_any ("i" ITZ SUM OF "i" AN 1) ("i" ITZ 1) (BOTH SAEM AN SMALLR OF "i" AN 5)
                  ("x" ITZ PRODUKT OF "x" AN 2).

Example ex10 : exists sg', p2 -{ env_notdecl }-> sg' /\ sg' "x" = numbr_e 32.
Proof.
  eexists.
  split.
  unfold p2.
  eapply seqBS. eapply seqBS.
  eapply decl_ZBS. eauto.
  eapply equal_ZBS. eapply constantBS. reflexivity.
  eapply forany_trueBS. eapply lesseqBS. eapply identBS. eapply constantBS.
  simpl. (* eauto. *)
Admitted.

(* Defining a stack machine to create a compiler - not complete *)

Inductive Var := string.
Definition AEnv := Var -> Z.
Definition Aenv0 := fun x => if string_dec x "x" then 10 else 0.
Check Aenv0.

Inductive AExp' :=
| aconst' : Z -> AExp'
| aid' : Var -> AExp'
| plus' : AExp' -> AExp' -> AExp'
| minus' : AExp' -> AExp' -> AExp'
| multiply' : AExp' -> AExp' -> AExp'
| divide' : AExp' -> AExp' -> AExp'.

Fixpoint Ainterpret (e : AExp') (env : AEnv) : Z :=
  match e with
  | aconst' c => c
  | aid' x => (env x)
  | plus' e1 e2 => (Ainterpret e1 env) + (Ainterpret e2 env)
  | multiply' e1 e2 => (Ainterpret e1 env) * (Ainterpret e2 env)
  | minus' e1 e2 => (Ainterpret e1 env) - (Ainterpret e2 env)
  | divide' e1 e2 => Z.div (Ainterpret e1 env) (Ainterpret e2 env)
  end.

Inductive Instr :=
| push_const : Z -> Instr
| push_var : Var -> Instr
| plus_instr : Instr
| mult_instr : Instr
| diff_instr : Instr
| divv_instr : Instr.

Compute diff.

Definition Stack := list Z.
Fixpoint Arun_instruction (i : Instr)
         (env : AEnv) (stack : Stack) : Stack :=
  match i with
  | push_const c => (c :: stack)
  | push_var x => ((env x) :: stack)
  | plus_instr => match stack with
           | n1 :: n2 :: stack' => (n1 + n2) :: stack'
           | _ => stack
           end
  | mult_instr => match stack with
           | n1 :: n2 :: stack' => (n1 * n2) :: stack'
           | _ => stack
           end
  | diff_instr => match stack with
           | n1 :: n2 :: stack' => (n1 - n2) :: stack'
           | _ => stack
           end
  | divv_instr => match stack with
           | n1 :: n2 :: stack' => (Z.div n1 n2) :: stack'
           | _ => stack
           end
  end.

Fixpoint run_list (il : list Instr)
         (env : Var -> Z) (stack : Stack) : Stack :=
  match il with
  | [ ] => stack
  | i :: il' => run_list il' env (run_list i env stack)
  end.

Compute (Arun_instruction (push_const 93) env_notdecl []).
Compute (Arun_instruction (push_var "x") env_notdecl []).

Definition pgm1 := [ push_const 19 ; push_var "x" ].

Compute run_instructions pgm1 env0 [].

Fixpoint compile (e : AExp') : list Instr :=
  match e with
  | aconst' c => [push_const c]
  | aid' x => [push_var x]
  | plus' e1 e2 => (compile e1) ++ (compile e2) ++ [plus_instr]
  | diff' e1 e2 => (compile e1) ++ (compile e2) ++ [minus_instr]
  | multiply' e1 e2 => (compile e1) ++ (compile e2) ++ [multiply_instr]
  | divide' e1 e2 => (compile e1) ++ (compile e2) ++ [divide_instr]
  end.

Compute compile (plus' 2 (id "x")).

Compute interpret (plus' 2 (id "x") ) env_notdecl.
Compute run_instructions (compile (plus' 2 (id "x") )) env_notdecl [].

Lemma soundness_helper :
    forall e env stack is',
    run_list (compile e ++ is') env stack =
    run_list is' env ((Ainterpret e env) :: stack).
Proof.
    induction e; intros; simpl; trivial.
    - rewrite <- app_assoc.
      rewrite <- app_assoc.
      rewrite IHe1.
      rewrite IHe2.
      simpl.
      rewrite Z.add_comm.
      reflexivity.
    - rewrite <- app_assoc.
      rewrite <- app_assoc.
      rewrite IHe1.
      rewrite IHe2.
      simpl.
      rewrite Z.minus_comm.
      reflexivity.
    - rewrite <- app_assoc.
      rewrite <- app_assoc.
      rewrite IHe1.
      rewrite IHe2.
      simpl.
      rewrite Z.multiply_comm.
      reflexivity.
    - rewrite <- app_assoc.
      rewrite <- app_assoc.
      rewrite IHe1.
      rewrite IHe2.
      simpl.
      rewrite Z.div_comm.
      reflexivity.
Admitted.

Theorem soundness :
  forall e env,
    run_list (compile e) env [] =
    [Ainterpret e env].
Proof.
    intros.
    Check app_nil_r.
    rewrite <- app_nil_r with (l := (compile e)).
    rewrite soundness_helper.
    simpl. trivial.
Qed.


Require Import ZArith.
Require Import String.

Require Import imp_domains.
Require Import imp_rules.

Require Import proof.
Require Import proof_automation.

Require Import map_zipper.

Open Scope Z_scope.
Open Scope string_scope.

(* Mostly generic equality solver *)
Lemma app_equal {A B} (f g : A -> B) (x y : A) : f = g -> x = y -> f x = g y.
congruence.
Qed.
Ltac equate_term :=
  reflexivity ||
  match goal with
  | [|- @eq Z _ _] => auto with zarith || ring
  | [|- @eq bool _ _] => auto
  | [|- @eq string _ _] => auto
  | _ => apply app_equal;equate_term
  end.

Ltac equate_maps' :=
 (repeat
 match goal with [|- ?l ~= ?r] =>
  match r with
  | context C [?k |-> ?v] =>
    has_evar v; match l with
    | context [k |-> ?v'] => unify v v'
    end
  end
 end);
 items;
 (apply equivRefl || apply equivUnit || apply equivUnitL).

Ltac domain_solver := solve[match goal with
  | [|- _ = _] => equate_term
  | [|- _ ~= _] => equate_maps';equate_term
  | _ => solve [auto with zarith | ring]
  end].

(* Reorder arguments of BoolSpec_ind for nicer proof certificates *)
Definition case_bool_spec {P Q b} (b0 : BoolSpec P Q b)
   {P0 : bool -> Prop} (f : P -> P0 true) (f0 : Q -> P0 false) : P0 b :=
  @BoolSpec_ind P Q P0 f f0 b b0.

(* Depends on what Coq functions you use on primitive domains: *)
Ltac split_bool b := pattern b;match b with
| Z.leb ?x ?y => apply (case_bool_spec (Z.leb_spec x y));intro
end.

(* Actually language dependent: *)
Ltac split_stuck := idtac;match goal with
| [|- trans _ _ {| kcell := kra (k_inj_Stmt_KItem (If (BCon (k_wrap_zhBool_Bool ?b)) _ _)) _ |} _] =>
    split_bool b
end.

(* Specific to predicates used in a particular specification *)
Definition KCfg' code state : (kcfg -> Prop) :=
  fun c => match c with
  | KCfg code' state' => code' = code /\ state' ~= state
  end.
Lemma useKCfg' : forall code state (P : kcfg -> Prop),
  (forall state', state' ~= state -> P (KCfg code state')) ->
  forall k', KCfg' code state k' -> P k'.
intros until k'. destruct k', 1. subst. auto.
Qed.
Ltac trans_use_result := apply useKCfg';intros.

Ltac done_solver :=
  abstract (subst;simpl;repeat eexists;domain_solver).

(* Now the automation *)
Ltac run := domain_run domain_solver trans_use_result domain_solver split_stuck done_solver.
Ltac step := domain_step domain_solver trans_use_result domain_solver split_stuck.
Ltac solver := apply proved_sound;destruct 1;
               (eapply sstep;[econstructor(domain_solver)| ];instantiate;simpl;run).

Coercion k_wrap_zhInt_Int : Z >-> Int.
Coercion k_wrap_zhInt_KItem : Z >-> kitem.
Coercion k_token_Id : string >-> Id.
Coercion k_wrap_Id_KItem : Id >-> kitem.

Definition loop : Stmt :=
   While (Le (ACon 0) (Var "x"))
     (BStmt (Assign "x" (Add (Var "x") (ACon (-1))))).

Inductive loop_spec : kcfg -> (kcfg -> Prop) -> Prop :=
  loop_claim : forall (x : Z) rest, loop_spec
          (KCfg (kra (k_wrap_Stmt_KItem loop) rest)
                (kra "x" kdot |-> kra x kdot :* mapEmpty))
     (fun c => match c with
      | KCfg code m => code = rest /\ exists (x':Z), (m ~= kra "x" kdot |-> kra x' kdot) /\ x' < 0
      end).

Arguments sstep [cfg cstep X k P k'] _ _.
Arguments sdone [cfg cstep X k P] _.
Arguments dstep [cfg cstep X k P k'] _ _.
Arguments ddone [cfg cstep X k P] _.
Arguments dtrans [cfg cstep X k P Q] _ _.

Lemma first_proof : sound kstep loop_spec.
solver.
Qed.
Set Printing Depth 100.
Set Printing Width 400.
Print first_proof.

Definition program : Pgm :=
  k_label_zqintzuZSzu ["x" : Id]
    ((Seq (Assign "x" (ACon 10))
     (Seq loop
          (Assign "x" (Add (Var "x") (ACon 10)))))).

Inductive program_spec : kcfg -> (kcfg -> Prop) -> Prop :=
  program_loop_claim : forall (x : Z) krest state state_rest,
      state ~= kra "x" kdot |-> kra x kdot :* state_rest -> x >= -1 ->
      program_spec (KCfg (kra (k_wrap_Stmt_KItem loop) krest) state)
                   (KCfg' krest (kra "x" kdot |-> kra (-1) kdot :* state_rest))
 | program_claim : program_spec
      (KCfg (kra (k_wrap_Pgm_KItem program) kdot) mapEmpty)
      (KCfg' kdot (kra "x" kdot |-> kra 9 kdot)).

Lemma second_proof : sound kstep program_spec.
solver.
Qed.

Definition sum_loop :=
  (While (Le (ACon 1) (Var "n"))
    (BStmt (Seq (Assign "s" (Add (Var "s") (Var "n")))
                (Assign "n" (Add (Var "n") (ACon (-1)%Z)))))).
Definition sum_code :=
  Seq (Assign "s" (ACon 0)) sum_loop.

Inductive sum_spec : kcfg -> (kcfg -> Prop) -> Prop :=
| mult_claim : forall (nv sv : Z) m state,
    state ~= (kra "n" kdot |-> kra nv kdot :* kra "s" kdot |-> kra sv kdot :* m) ->
    (nv >= 0)%Z ->
    forall krest,
    sum_spec (KCfg (kra (k_wrap_Stmt_KItem sum_loop) krest) state)
             (KCfg' krest (kra "n" kdot |-> kra 0 kdot
                          :* kra "s" kdot |-> kra (sv + nv * (nv + 1) / 2) kdot
                          :* m))
| sum_claim : forall (nv : Z) sv m state,
    state ~= (kra "n" kdot |-> kra nv kdot :* kra "s" kdot |-> sv :* m) ->
    (nv >= 0)%Z ->
    forall krest,
    sum_spec (KCfg (kra (k_wrap_Stmt_KItem sum_code) krest) state)
             (KCfg' krest (kra "n" kdot |-> kra 0 kdot
                          :* kra "s" kdot |-> kra (nv * (nv + 1) / 2) kdot
                          :* m))
.

Lemma sum_math nv :
   (nv * (nv + 1) / 2)%Z = (nv + (nv - 1) * (nv - 1 + 1) / 2)%Z.
Proof.
rewrite <- Z.div_add_l by auto with zarith.
apply f_equal2;ring.
Qed.

Lemma sum_proof : sound kstep sum_spec.
solver.

+ rewrite sum_math.
  run.

+ replace nv with 0%Z by auto with zarith.
  run.
Qed.
Print sum_proof.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__NChelper.
Require Export lemma__NCorder.
Require Export lemma__betweennotequal.
Require Export lemma__collinearorder.
Require Export lemma__equalanglesreflexive.
Require Export lemma__ray4.
Require Export logic.
Definition proposition__13 : forall A B C D, (euclidean__axioms.BetS D B C) -> ((euclidean__axioms.nCol A B C) -> (euclidean__defs.RT C B A A B D)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
intro H0.
assert (* Cut *) (A = A) as H1.
- apply (@logic.eq__refl Point A).
- assert (* Cut *) (euclidean__axioms.neq B A) as H2.
-- assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H2.
--- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H0).
--- destruct H2 as [H3 H4].
destruct H4 as [H5 H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
exact H9.
-- assert (* Cut *) (euclidean__defs.Out B A A) as H3.
--- apply (@lemma__ray4.lemma__ray4 B A A).
----right.
left.
exact H1.

---- exact H2.
--- assert (* Cut *) (euclidean__axioms.BetS C B D) as H4.
---- apply (@euclidean__axioms.axiom__betweennesssymmetry D B C H).
---- assert (* Cut *) (euclidean__defs.Supp C B A A D) as H5.
----- split.
------ exact H3.
------ exact H4.
----- assert (* Cut *) (euclidean__axioms.nCol C B A) as H6.
------ assert (* Cut *) ((euclidean__axioms.nCol B A C) /\ ((euclidean__axioms.nCol B C A) /\ ((euclidean__axioms.nCol C A B) /\ ((euclidean__axioms.nCol A C B) /\ (euclidean__axioms.nCol C B A))))) as H6.
------- apply (@lemma__NCorder.lemma__NCorder A B C H0).
------- destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
exact H14.
------ assert (* Cut *) (euclidean__axioms.Col D B C) as H7.
------- right.
right.
right.
right.
left.
exact H.
------- assert (* Cut *) (euclidean__axioms.Col C B D) as H8.
-------- assert (* Cut *) ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D C B) /\ (euclidean__axioms.Col C B D))))) as H8.
--------- apply (@lemma__collinearorder.lemma__collinearorder D B C H7).
--------- destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
exact H16.
-------- assert (* Cut *) (B = B) as H9.
--------- apply (@logic.eq__refl Point B).
--------- assert (* Cut *) (euclidean__axioms.Col C B B) as H10.
---------- right.
right.
left.
exact H9.
---------- assert (* Cut *) (euclidean__axioms.neq D B) as H11.
----------- assert (* Cut *) ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq D B) /\ (euclidean__axioms.neq D C))) as H11.
------------ apply (@lemma__betweennotequal.lemma__betweennotequal D B C H).
------------ destruct H11 as [H12 H13].
destruct H13 as [H14 H15].
exact H14.
----------- assert (* Cut *) (euclidean__axioms.nCol D B A) as H12.
------------ apply (@euclidean__tactics.nCol__notCol D B A).
-------------apply (@euclidean__tactics.nCol__not__Col D B A).
--------------apply (@lemma__NChelper.lemma__NChelper C B A D B H6 H8 H10 H11).

------------ assert (* Cut *) (euclidean__axioms.nCol A B D) as H13.
------------- assert (* Cut *) ((euclidean__axioms.nCol B D A) /\ ((euclidean__axioms.nCol B A D) /\ ((euclidean__axioms.nCol A D B) /\ ((euclidean__axioms.nCol D A B) /\ (euclidean__axioms.nCol A B D))))) as H13.
-------------- apply (@lemma__NCorder.lemma__NCorder D B A H12).
-------------- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H21.
------------- assert (* Cut *) (euclidean__defs.CongA A B D A B D) as H14.
-------------- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive A B D H13).
-------------- assert (* Cut *) (euclidean__defs.CongA C B A C B A) as H15.
--------------- apply (@lemma__equalanglesreflexive.lemma__equalanglesreflexive C B A H6).
--------------- assert (* Cut *) (euclidean__defs.RT C B A A B D) as H16.
---------------- exists C.
exists B.
exists D.
exists A.
exists A.
split.
----------------- exact H5.
----------------- split.
------------------ exact H15.
------------------ exact H14.
---------------- exact H16.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Bijection.
Require Import Logic.lib.Countable.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.Complete.ContextProperty.
Require Import Logic.GeneralLogic.Complete.ContextProperty_Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Complete.ContextProperty_Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.RewriteClass.
Require Import Logic.PropositionalLogic.ProofTheory.ProofTheoryPatterns.

Local Open Scope logic_base.
Local Open Scope syntax.
Import PropositionalLanguageNotation.

Section ContextProperties.

Context {L: Language}
        {minL: MinimumLanguage L}
        {pL: PropositionalLanguage L}.

Definition orp_witnessed: context -> Prop :=
  fun Phi => forall x y, Phi (orp x y) -> Phi x \/ Phi y.

Context {GammaP: Provable L} {GammaD: Derivable L}.

Definition context_orp (Phi Psi: context): context :=
  fun z => exists x y, z = x || y /\ Phi |-- x /\ Psi |-- y.

Definition context_orp_captured (P: context -> Prop): Prop :=
  forall Phi Psi, P (context_orp Phi Psi) -> P Phi \/ P Psi.

Context {SC: NormalSequentCalculus L GammaP GammaD}
        {bSC: BasicSequentCalculus L GammaD}
        {minSC: MinimumSequentCalculus L GammaD}
        {ipSC: IntuitionisticPropositionalSequentCalculus L GammaD}
        {minAX: MinimumAxiomatization L GammaP}
        {ipAX: IntuitionisticPropositionalLogic L GammaP}.

Lemma context_orp_mono: forall Phi Psi Phi' Psi',
  Included _ (derivable Phi) (derivable Phi') ->
  Included _ (derivable Psi) (derivable Psi') ->
  Included _ (context_orp Phi Psi) (context_orp Phi' Psi').
Proof.
  intros.
  hnf; unfold Ensembles.In; intros.
  hnf in H1 |- *.
  destruct H1 as [y [z [? [? ?]]]]; subst.
  exists y, z.
  split; [| split]; auto.
  + apply H; auto.
  + apply H0; auto.
Qed.

Lemma context_orp_mono': forall Phi Psi Phi' Psi',
  Included _ Phi Phi' ->
  Included _ Psi Psi' ->
  Included _ (context_orp Phi Psi) (context_orp Phi' Psi').
Proof.
  intros.
  apply context_orp_mono; hnf; intros; eapply deduction_weaken; eauto.
Qed.

Lemma cannot_derive_context_orp_captured: forall (x: expr),
  context_orp_captured (cannot_derive x).
Proof.
  intros.
  unfold cannot_derive.
  hnf; intros.
  apply not_and_or.
  intros [? ?]; apply H; clear H.
  rewrite <- (orp_dup x).
  apply derivable_assum.
  exists x, x.
  split; [| split]; auto.
Qed.

Lemma DCS_truep: forall (Phi: context),
  derivable_closed Phi ->
  Phi TT.
Proof.
  intros.
  apply H.
  apply derivable_impp_refl.
Qed.

Lemma DCS_andp_iff: forall (Phi: context),
  derivable_closed Phi ->
  (forall x y: expr, Phi (x && y) <-> (Phi x /\ Phi y)).
Proof.
  intros.
  pose proof derivable_closed_element_derivable _ H; clear H.
  rewrite !H0; clear H0; split; intros.
  + pose proof deduction_andp_elim1 Phi x y H.
    pose proof deduction_andp_elim2 Phi x y H.
    auto.
  + destruct H.
    pose proof deduction_andp_intros Phi x y H H0.
    auto.
Qed.

Lemma DCS_iffp: forall (Phi: context) (x y: expr),
  derivable_closed Phi ->
  |-- x <--> y ->
  (Phi x <-> Phi y).
Proof.
  intros.
  split; intros.
  + apply H.
    rewrite <- H0.
    apply derivable_assum; auto.
  + apply H.
    rewrite H0.
    apply derivable_assum; auto.
Qed.

Lemma DCS_multi_and_iff: forall (Phi: context),
  derivable_closed Phi ->
  (forall xs: list expr, Phi (multi_and xs) <-> Forall Phi xs).
Proof.
  intros.
  rewrite (DCS_iffp Phi (multi_and xs) (fold_right andp TT xs)).
  2: auto.
  2: apply multi_and_spec.

  induction xs.
  + split; intros.
    - constructor.
    - simpl.
      apply DCS_truep; auto.
  + simpl.
    rewrite DCS_andp_iff by auto.
    rewrite IHxs.
    clear.
    split; intros.
    - constructor; tauto.
    - inversion H; auto.
Qed.

Lemma DCS_orp_iff: forall (Phi: context),
  derivable_closed Phi ->
  orp_witnessed Phi ->
  (forall x y: expr, Phi (x || y) <-> (Phi x \/ Phi y)).
Proof.
  intros.
  pose proof derivable_closed_element_derivable _ H; clear H.
  split; intros.
  + apply H0; auto.
  + rewrite !H1 in *.
    destruct H.
    - pose proof deduction_orp_intros1 Phi x y H; auto.
    - pose proof deduction_orp_intros2 Phi x y H; auto.
Qed.

Lemma derivable_closed_union_derivable {AX: NormalAxiomatization L GammaP GammaD}: forall (Phi Psi: context) (x: expr),
  derivable_closed Psi ->
  Union _ Phi Psi |-- x ->
  exists y, Psi y /\ Phi |-- y --> x.
Proof.
  intros.
  rewrite derivable_provable in H0.
  destruct H0 as [xs [? ?]].
  pose proof provable_multi_imp_split _ _ _ _ H0 H1 as [xs1 [xs2 [? [? ?]]]].
  pose proof H4.
  rewrite <- multi_and_multi_imp in H4.
  eapply modus_ponens in H4; [| apply provable_multi_imp_arg_switch1].
  exists (multi_and xs2).
  split.
  + apply DCS_multi_and_iff; auto.
  + rewrite derivable_provable.
    exists xs1.
    split; auto.
    eapply modus_ponens.
    - apply provable_multi_imp_weaken.
      rewrite (multi_and_multi_imp xs2 x).
      apply provable_impp_refl.
    - exact H5.
Qed.

Lemma consistent_spec:
  forall (Phi: context), consistent Phi <-> ~ Phi |-- FF.
Proof.
  intros.
  split; intros.
  + intro.
    destruct H as [x H]; apply H; clear H.
    apply deduction_falsep_elim.
    auto.
  + exists FF; auto.
Qed.

End ContextProperties.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable supp_ : Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable rT_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.

Variable deftworightangles_1 : (forall A B C D E F : Universe, (exists X Y Z U V : Universe, (rT_ A B C D E F -> (supp_ X Y U V Z /\ (congA_ A B C X Y U /\ congA_ D E F V Y Z))))).
Variable deftworightangles2_2 : (forall A B C D E F X Y Z U V : Universe, ((supp_ X Y U V Z /\ (congA_ A B C X Y U /\ congA_ D E F V Y Z)) -> rT_ A B C D E F)).
Variable lemma_equalanglessymmetric_3 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> congA_ Xa Xb Xc A B C)).
Variable lemma_equalanglestransitive_4 : (forall A B C D E F P Q R : Universe, ((congA_ A B C D E F /\ congA_ D E F P Q R) -> congA_ A B C P Q R)).

Theorem lemma_RTcongruence_5 : (forall A B C D E F P Q R : Universe, ((rT_ A B C D E F /\ congA_ A B C P Q R) -> rT_ P Q R D E F)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import lambda.
Require Import maps.
Require Import ZArith.

Open Scope list.

(* assume the existence of some map operations *)

(* add an entry, requiring it to be free *)
Axiom alloc : forall {A}, loc -> A -> Map loc A -> option (Map loc A).
(* remove a binding, requiring it to exist *)
Axiom free : forall {A}, loc -> Map loc A -> option (Map loc A).
(* update an existing binding *)
Axiom poke : forall {A}, loc -> A -> Map loc A -> option (Map loc A).
(* lookup the value of a binding *)
Axiom peek : forall {A}, loc -> Map loc A -> option A.

(* Attempt to make an evaluation function *)
Definition lam_step' (c : cfg) : option cfg :=
  match c with
    | Cfg (Exp e p) s m k =>
      match e with
        | Lit v => Some (Cfg (Val v) s m k)
        | Seq e e' => Some (Cfg (Exp e p) s m (SeqCtx e' p k))
        | Lam body => Some (Cfg (Val (Closure body p)) s m k)
        | Var i =>
          match p with
            | Env l =>
              match get i l with
                | Some v => Some (Cfg (Val v) s m k)
                | None => None
              end
          end
        | App e0 e1 => Some (Cfg (Exp e0 p) s m (AppFun e1 p k))
        | Ref e => Some (Cfg (Exp e p) s m (RefVal k))
        | Dealloc e => Some (Cfg (Exp e p) s m (DeallocCtx k))
        | Deref e => Some (Cfg (Exp e p) s m (DerefTgt k))
        | Assign e e' => Some (Cfg (Exp e p) s m (AssignTgt e' p k))
        | If ec t e => Some (Cfg (Exp ec p) s m (IfCond t e p k))
        | Closed e => Some (Cfg (Exp e (Env nil)) s m k)
      end
    | Cfg (Val v) s m k =>
      match k with
        | Top => None
        | AppFun e p k => Some (Cfg (Exp e p) s m (AppArg v k))
        | AppArg f k =>
          match apply f v with
            | Some c => Some (Cfg c s m k)
            | _ => None
          end
        | SeqCtx e p k =>
          Some (Cfg (Exp e p) s m k)
        | RefVal k =>
            match alloc m v s with
            | Some s' => Some (Cfg (Val (Addr m)) s' (m+1)%Z k)
            | None => None
            end
        | DerefTgt k =>
          match v with
            | Addr l =>
              match peek l s with
                | Some v => Some (Cfg (Val v) s m k)
                | _ => None
              end
            | _ => None
          end
        | AssignTgt e p k =>
          match v with
            | Addr l => Some (Cfg (Exp e p) s m (AssignVal l k))
            | _ => None
          end
        | AssignVal l k =>
          match poke l v s with
            | Some s' => Some (Cfg (Val v) s' m k)
            | None => None
          end
        | DeallocCtx k =>
          match v with
            | Addr l =>
              match free l s with
                | Some s' => Some (Cfg (Val Nil) s' m k)
                | None => None
              end
            | _ => None
          end
        | IfCond t e p k =>
          Some (Cfg (Exp (if isNil v then e else t) p) s m k)
      end
  end.
Functional Scheme lam_step'_ind := Induction for lam_step' Sort Prop.

Ltac inject1 :=
  let H := fresh in intro H; injection H; clear H;intro;subst.
Lemma func_valid : forall st st',
  lam_step' st = Some st' -> lam_step st st'.
intros st st';functional induction (lam_step' st);(discriminate 1 || inject1);
try solve[constructor(assumption)].
(* the remaining four clauses use the axiomatized map operations *)
admit.
admit.
admit.
admit.
Qed.

(* This one actually needs some kind of well-formedness assumption on the map,
   to ensure the deterministic peek/poke result agrees with
   the pattern-based statement *)
Lemma func_complete : forall st st',
   lam_step st st' -> lam_step' st = Some st'.
destruct 1;simpl; try match goal with
| [H : ?l = _ |- _] => rewrite H
end;try reflexivity.
admit.
admit.
admit.
admit.
Qed.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Frederic Blanqui, 2009-09-09

non-collapsing arguments filtering with permutations
*)

Set Implicit Arguments.

From CoLoR Require Import LogicUtil ATrs ListUtil NatUtil VecUtil SN BoolUtil
     RelUtil ListNodup VecFilterPerm ARelation ACompat NaryFunction BoundNat
     ListDec.

Section S.

  Variable Sig : Signature.

  Section pi.

    Variable pi : forall f : Sig, list (N (arity f)).

(***********************************************************************)
(** Assumption: pi does not duplicate arguments.

This hyp is not really necessary but it makes the proof of weak
monotony simpler. Otherwise, we also need to assume that the ordering
is transitive. *)

    Definition non_dup := forall f, nodup (map N_val (pi f)).

    Variable hyp : non_dup.

(***********************************************************************)
(** filtered signature *)

    Definition filter_arity f := length (pi f).

    Definition filter_sig := mkSignature filter_arity (@beq_symb_ok Sig).

    Notation Sig' := filter_sig. Notation term' := (term Sig').
    Notation term := (term Sig). Notation terms := (vector term).

(***********************************************************************)
(** term filtering *)

    Fixpoint filter (t : term) : term' :=
      match t with
        | Var x => Var x
        | Fun f ts => @Fun Sig' f (Vfilter (pi f) (Vmap filter ts))
      end.

(***********************************************************************)
(** rule filtering *)

    Notation rule := (ATrs.rule Sig). Notation rules := (list rule).
    Notation rule' := (ATrs.rule Sig'). Notation rules' := (list rule').

    Definition filter_rule a := mkRule (filter (lhs a)) (filter (rhs a)).

    Notation filter_rules := (map filter_rule).

(***********************************************************************)
(** properties of term filtering wrt substitutions *)

    Definition filter_subs s (x : variable) := filter (s x).

    Lemma filter_sub : forall s t,
      filter (sub s t) = sub (filter_subs s) (filter t).

    Proof.
      intro. apply term_ind_forall with (P := fun t =>
      filter (sub s t) = sub (filter_subs s) (filter t)); intros; simpl.
      refl. apply args_eq. rewrite !Vfilter_map, !Vmap_map.
      apply Vmap_eq. eapply Vforall_incl with (v2 := v). intros.
      eapply Vin_filter_elim_in. apply H0. hyp.
    Qed.

(***********************************************************************)
(** filter ordering *)

    Section filter_ordering.

      Variable succ : relation term'.

      Definition filter_ord : relation term :=
        fun t u => succ (filter t) (filter u).

      Notation fsucc := filter_ord.

(***********************************************************************)
(** preservation of transitivity *)

      (*FIXME: define a meta-theorem*)
      Lemma filter_trans : transitive succ -> transitive fsucc.

      Proof.
        intro. unfold transitive, filter_ord. intros. eapply H. apply H0. hyp.
      Qed.

(***********************************************************************)
(** preservation of well-foundedness *)

      (*FIXME: define a meta-theorem*)
      Lemma WF_filter : WF succ -> WF fsucc.

      Proof. intro. unfold filter_ord. apply (WF_inverse filter H). Qed.

(***********************************************************************)
(** stability by substitution *)

      (*FIXME: define a meta-theorem*)
      Lemma filter_subs_closed :
        substitution_closed succ -> substitution_closed fsucc.

      Proof.
        unfold substitution_closed. intros. unfold filter_ord.
        rewrite !filter_sub. apply H. hyp.
      Qed.

(***********************************************************************)
(** compatibility *)

       (*FIXME: define a meta-theorem*)
      Lemma filter_comp : forall R : rules,
        compat succ (filter_rules R) -> compat fsucc R.

      Proof.
        unfold compat. intros. unfold filter_ord. apply H.
        change (In (filter_rule (mkRule l r)) (filter_rules R)).
        apply in_map. hyp.
      Qed.

(***********************************************************************)
(** weak monotony wrt contexts *)

      Lemma filter_weak_cont_closed :
        reflexive succ -> context_closed succ -> context_closed fsucc.

      Proof.
        rewrite <- !Vmonotone_context_closed.
        unfold Vmonotone, Vmonotone_i, RelUtil.monotone.
        intros hrefl hcc f i j e vi vj. unfold fsucc. simpl. intros t u.
        set (t' := filter t). set (u' := filter u). intro h'.
        rewrite !Vmap_cast, !Vmap_app. simpl. fold t' u'.
        set (vi' := Vmap filter vi). set (vj' := Vmap filter vj).
        set (vt := Vcast (Vapp vi' (Vcons t' vj')) e).
        set (vu := Vcast (Vapp vi' (Vcons u' vj')) e).
        case (In_dec eq_nat_dec i (map N_val (pi f))); intro Hi.

        (*REMARK: sub-proof to be extracted since it is used both in
           filter_cont_closed and in red_incl_filter_red_rc *)

        (* i in (pi f) *)
        destruct (in_map_elim Hi) as [x [hx vx]].
        destruct (in_elim hx) as [l1 [l2 hf]].

        assert (a: length l1+length(x::l2)=@arity Sig' f).
        unfold arity, filter_sig, filter_arity. rewrite hf, length_app. refl.
        rewrite (Vfilter_app_eq (v:=vt) a hf), (Vfilter_app_eq (v:=vu) a hf).
        simpl.

        ded (hyp f). unfold non_dup in H. rewrite hf, map_app in H.
        simpl in H. destruct (nodup_app_cons H) as [h1 h2].
        rewrite <- vx in h1. rewrite <- vx in h2.

        assert (e1 : Vfilter l1 vt = Vfilter l1 vu). apply Vfilter_eq_notin.
        intros hi h. ded (in_map N_val h). contr. rewrite e1.
        assert (e2 : Vfilter l2 vt = Vfilter l2 vu). apply Vfilter_eq_notin.
        intros hi h. ded (in_map N_val h). contr. rewrite e2.

        apply hcc. unfold vt, vu. rewrite !Vnth_cast, !Vnth_app.
        destruct (le_gt_dec i x). 2: lia.
        repeat (rewrite Vnth_cons_head; [idtac|rewrite vx;lia]). hyp.

        (* i not in (pi f) *)
        apply eq_incl_refl_rel. hyp. apply args_eq. unfold vt, vu.
        apply Vfilter_eq_notin with (l:=pi f). intros hi h.
        ded (in_map N_val h). contr.
      Qed.

(***********************************************************************)
(** strong monotony wrt contexts *)

      Definition permut := forall f i,
        i < arity f -> In i (map N_val (pi f)).

      Lemma filter_strong_cont_closed :
        permut -> context_closed succ -> context_closed fsucc.

      Proof.
        rewrite <- !Vmonotone_context_closed.
        unfold Vmonotone, Vmonotone_i, RelUtil.monotone.
        intros hp hcc f i j e vi vj. unfold fsucc. simpl. intros t u.
        set (t' := filter t). set (u' := filter u). intro h'.
        rewrite !Vmap_cast, !Vmap_app. simpl. fold t' u'.
        set (vi' := Vmap filter vi). set (vj' := Vmap filter vj).
        set (vt := Vcast (Vapp vi' (Vcons t' vj')) e).
        set (vu := Vcast (Vapp vi' (Vcons u' vj')) e).
        case (In_dec eq_nat_dec i (map N_val (pi f))); intro Hi.

        (*REMARK: sub-proof to be extracted since it is used both in
           filter_cont_closed and in red_incl_filter_red_rc *)

        (* i in (pi f) *)
        destruct (in_map_elim Hi) as [x [hx vx]].
        destruct (in_elim hx) as [l1 [l2 hf]].

        assert (a: length l1+length(x::l2)=@arity Sig' f).
        unfold arity, filter_sig, filter_arity. rewrite hf, length_app. refl.
        rewrite (Vfilter_app_eq (v:=vt) a hf), (Vfilter_app_eq (v:=vu) a hf).
        simpl.

        ded (hyp f). unfold non_dup in H. rewrite hf, map_app in H.
        simpl in H. destruct (nodup_app_cons H) as [h1 h2].
        rewrite <- vx in h1. rewrite <- vx in h2.

        assert (e1 : Vfilter l1 vt = Vfilter l1 vu). apply Vfilter_eq_notin.
        intros hi h. ded (in_map N_val h). contr. rewrite e1.
        assert (e2 : Vfilter l2 vt = Vfilter l2 vu). apply Vfilter_eq_notin.
        intros hi h. ded (in_map N_val h). contr. rewrite e2.

        apply hcc. unfold vt, vu. rewrite !Vnth_cast, !Vnth_app.
        destruct (le_gt_dec i x). 2: lia.
        repeat (rewrite Vnth_cons_head; [idtac|rewrite vx;lia]). hyp.

        (* i not in (pi f) *)
        assert (hi : i<arity f). lia. ded (hp f i hi). contr.
      Qed.

    End filter_ordering.

(***********************************************************************)
(** monotony wrt inclusion *)

    (*FIXME: define a meta-theorem*)
    Lemma incl_filter : forall R S, R << S -> filter_ord R << filter_ord S.

    Proof. intros. unfold inclusion, filter_ord. intros. apply H. exact H0. Qed.

(***********************************************************************)
(** rewriting *)

    Section red.

      Variable R : rules. Notation R' := (filter_rules R).

      (*FIXME: define a meta-theorems?*)
      Lemma red_incl_filter_red_rc : red R << filter_ord (red R'%).

      Proof.
        unfold inclusion, filter_ord. intros. redtac. subst x. subst y.
        elim c; clear c.
        (* Hole *)
        simpl. right. rewrite !filter_sub. apply red_rule_top.
        change (In (filter_rule (mkRule l r)) R'). apply in_map. hyp.
        (* Cont *)
        intros f i j e vi c.
        set (t := filter (fill c (sub s l))).
        set (u := filter (fill c (sub s r))).
        intros htu vj. simpl. rewrite !Vmap_cast, !Vmap_app. simpl.
        fold t u. set (vi' := Vmap filter vi). set (vj' := Vmap filter vj).
        destruct htu as [htu|htu]. rewrite htu. left. refl.
        case (In_dec eq_nat_dec i (map N_val (pi f))); intro Hi.

        (*REMARK: sub-proof to be extracted since it is used both in
           filter_cont_closed and in red_incl_filter_red_rc *)

        (* i in (pi f) *)
        right. destruct (in_map_elim Hi) as [x [hx vx]].
        destruct (in_elim hx) as [l1 [l2 hf]].
        set (vt := Vcast (Vapp vi' (Vcons t vj')) e).
        set (vu := Vcast (Vapp vi' (Vcons u vj')) e).

        assert (a: length l1+length(x::l2)=@arity Sig' f).
        unfold arity, filter_sig, filter_arity. rewrite hf, length_app. refl.
        rewrite (Vfilter_app_eq a hf), (Vfilter_app_eq a hf). simpl.
        set (v1 := Vfilter l1 vu). set (v2 := Vfilter l2 vu).
        simpl in a. set (d := Cont (Sig:=Sig') f a v1 Hole v2).

        ded (hyp f). unfold non_dup in H. rewrite hf, map_app in H.
        simpl in H. destruct (nodup_app_cons H) as [h1 h2].
        rewrite <- vx in h1. rewrite <- vx in h2.

        assert (e1 : Vfilter l1 vt = Vfilter l1 vu). apply Vfilter_eq_notin.
        intros hi h. ded (in_map N_val h). contr. rewrite e1.
        assert (e2 : Vfilter l2 vt = Vfilter l2 vu). apply Vfilter_eq_notin.
        intros hi h. ded (in_map N_val h). contr. rewrite e2.

        unfold vt, vu. rewrite !Vnth_cast, !Vnth_app.
        destruct (le_gt_dec i x). 2: lia.
        repeat (rewrite Vnth_cons_head; [idtac|lia]).
        change (red R' (fill d t) (fill d u)). apply red_fill. hyp.

        (* i not in (pi f) *)
        left. apply args_eq. apply Vfilter_eq_notin with (l:=pi f). intros hi h.
        ded (in_map N_val h). contr.
      Qed.

      Lemma red_rtc_incl_filter_red_rtc : red R # << filter_ord (red R' #).

      Proof.
        unfold inclusion. induction 1.
        apply incl_filter with (red R'%). apply rc_incl_rtc.
        apply red_incl_filter_red_rc. exact H.
        unfold filter_ord. apply rt_refl.
        unfold filter_ord. apply rt_trans with (filter y).
        apply IHclos_refl_trans1. apply IHclos_refl_trans2.
      Qed.

      Lemma hd_red_incl_filter_hd_red : hd_red R << filter_ord (hd_red R').

      Proof.
        unfold inclusion, filter_ord. intros. redtac. subst x. subst y.
        rewrite !filter_sub. apply hd_red_rule.
        change (In (filter_rule (mkRule l r)) R'). apply in_map. hyp.
      Qed.

    End red.

(***********************************************************************)
(** rewriting modulo *)

    (*FIXME: define meta-theorems*)
    Section red_mod.

      Variable E R : rules.

      Notation E' := (filter_rules E). Notation R' := (filter_rules R).

      Lemma hd_red_mod_filter : hd_red_mod E R << filter_ord (hd_red_mod E' R').

      Proof.
        unfold inclusion, filter_ord. intros. redtac. exists (filter t). split.
        apply red_rtc_incl_filter_red_rtc. exact H.
        subst t. subst y. rewrite !filter_sub. apply hd_red_rule.
        change (In (filter_rule (mkRule l r)) R'). apply in_map. hyp.
      Qed.

      Lemma WF_hd_red_mod_filter : WF (hd_red_mod E' R') -> WF (hd_red_mod E R).

      Proof.
        intro. eapply WF_incl. apply hd_red_mod_filter. apply WF_filter. hyp.
      Qed.

    End red_mod.

  End pi.

(***********************************************************************)
(** building a filtering function *)

  Section build_pi.

    Variable raw_pi : Sig -> list nat.

    Definition valid := forall f x, In x (raw_pi f) -> arity f > x.

    Variable Fs : list Sig.
    Variable Fs_ok : forall f : Sig, In f Fs.

    Definition bvalid :=
      forallb (fun f => forallb (bgt_nat (arity f)) (raw_pi f)) Fs.

    Lemma bvalid_ok : bvalid = true <-> valid.

    Proof.
      apply forallb_ok_fintype. 2: hyp. intro f. rewrite forallb_forall.
      intuition. rewrite <- bgt_nat_ok. auto. rewrite bgt_nat_ok. auto.
    Qed.

    Variable raw_pi_ok : bvalid = true.

    Definition build_nat_lts : forall n l,
      forallb (bgt_nat n) l = true -> list (N n).

    Proof.
      induction l; simpl; intros. exact nil.
      eapply cons. eapply N_.
      rewrite andb_eq in H. destruct H. rewrite bgt_nat_ok in H. apply H.
      apply IHl.
      rewrite andb_eq in H. destruct H. hyp.
    Defined.

    Arguments build_nat_lts [n l] _.

    Lemma build_nat_lts_ok : forall n l (h : forallb (bgt_nat n) l = true),
      map N_val (build_nat_lts h) = l.

    Proof. induction l; simpl; intros. refl. rewrite IHl. refl. Qed.

    Definition build_pi : forall f : Sig, list (N (arity f)).

    Proof.
      intro f. eapply build_nat_lts. unfold bvalid in raw_pi_ok.
      rewrite forallb_forall in raw_pi_ok. apply raw_pi_ok. apply Fs_ok.
    Defined.

    Lemma build_pi_ok : forall f, map N_val (build_pi f) = raw_pi f.

    Proof. intro. apply build_nat_lts_ok. Qed.

(***********************************************************************)
(** verifying arguments non-duplication *)

    Definition bnon_dup :=
      forallb (fun f => bnodup beq_nat (raw_pi f)) Fs.

    Lemma bnon_dup_ok : bnon_dup = true <-> non_dup build_pi.

    Proof.
      unfold bnon_dup, non_dup. apply forallb_ok_fintype. 2: apply Fs_ok.
      intro f. rewrite build_pi_ok. apply bnodup_ok. apply beq_nat_ok.
    Qed.

(***********************************************************************)
(** verify if all filters are permutations *)

    Definition bpermut :=
      forallb (fun f =>
        bforall_lt (fun i => mem beq_nat i (raw_pi f)) (arity f)) Fs.

    Lemma bpermut_ok : bpermut = true <-> permut build_pi.

    Proof.
      unfold bpermut, permut. apply forallb_ok_fintype. 2: hyp.
      intro f. apply bforall_lt_ok. intro x. rewrite build_pi_ok.
      apply mem_ok. apply beq_nat_ok.
    Qed.

  End build_pi.

End S.

Arguments filter_sig [Sig] _.
Arguments bvalid [Sig] _ _.
Arguments build_pi [Sig raw_pi Fs] _ _ _.
Arguments bnon_dup_ok [Sig raw_pi Fs] _ _.
Arguments non_dup [Sig] _.
Arguments bpermut_ok [Sig raw_pi Fs] _ _.
Arguments permut [Sig] _.

(***********************************************************************)
(** tactics *)

Ltac non_dup :=
  match goal with
    | |- non_dup (build_pi _ _) => rewrite <- bnon_dup_ok; check_eq
    | |- non_dup ?pi => unfold pi; non_dup
  end || fail 10 "duplicating arguments filter".

Ltac permut :=
  match goal with
    | |- permut (build_pi _ _) => rewrite <- bpermut_ok; check_eq
    | |- permut ?pi => unfold pi; permut
  end || fail 10 "non-permutative arguments filter".

(*COQ: does not work... the recursive call on filter fails...
Ltac filter p :=
  match goal with
    | |- WF (hd_red_Mod _ _) => hd_red_mod; filter p
    | |- WF (hd_red_mod _ _) =>
      apply WF_hd_red_mod_filter with (pi:=p); [non_dup | idtac]
  end.*)

Ltac filter p :=
  hd_red_mod; apply WF_hd_red_mod_filter with (pi:=p); [non_dup | idtac].

Ltac prove_cc_succ tac :=
  apply filter_strong_cont_closed; [non_dup | permut | tac].

(***********************************************************************)
(** signature functor *)

Module Type Filter.
  Parameter Sig : Signature.
  Parameter pi : forall f : Sig, list (N (arity f)).
End Filter.

Module Make (S : FSIG) (F : Filter with Definition Sig := S.Sig) <: FSIG.
  Definition Sig := filter_sig F.pi.
  Definition Fs := S.Fs.
  Definition Fs_ok := S.Fs_ok.
End Make.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics HoTT.Types UnivalenceImpliesFunext.
Require Import Idempotents.
Require Import HoTT.Truncations Spaces.BAut Spaces.Cantor.

Local Open Scope equiv_scope.
Local Open Scope path_scope.

(** * BAut(Cantor) *)

(** ** A pre-idempotent on [BAut Cantor] that does not split *)

(** We go into a non-exported module so that we can use short names for definitions without polluting the global namespace. *)

Module BAut_Cantor_Idempotent.
Section Assumptions.
  Context `{Univalence}.

  Definition f : BAut Cantor -> BAut Cantor.
  Proof.
    intros Z.
    (** Here is the important part of this definition. *)
    exists (Z + Cantor)%type.
    (** The rest is just a proof that [Z+Cantor] is again equivalent to [Cantor], using [cantor_fold] and the assumption that [Z] is equivalent to [Cantor]. *)
    pose (e := Z.2); simpl in e; clearbody e.
    strip_truncations.
    apply tr.
    apply path_universe_uncurried.
    refine (equiv_cantor_fold oE _).
    refine (equiv_path _ _ e +E 1).
  Defined.

  (** For the pre-idempotence of [f], the main point is again the existence of the equivalence [fold_cantor]. *)
  Definition preidem_f : IsPreIdempotent f.
  Proof.
    intros Z.
    apply path_baut.
    unfold f; simpl.
    refine (_ oE equiv_sum_assoc Z Cantor Cantor).
    apply (1 +E equiv_cantor_fold).
  Defined.

  (** We record how the action of [f] and [f o f] on paths corresponds to an action on equivalences. *)
  Definition ap_f {Z Z' : BAut Cantor} (p : Z = Z')
  : equiv_path _ _ (ap f p)..1
    = equiv_path Z Z' p..1 +E 1.
  Proof.
    destruct p. apply path_equiv, path_arrow.
    intros [z|a]; reflexivity.
  Defined.

  Definition ap_ff {Z Z' : BAut Cantor} (p : Z = Z')
  : equiv_path _ _ (ap (f o f) p)..1
    = equiv_path Z Z' p..1 +E 1 +E 1.
  Proof.
    destruct p. apply path_equiv, path_arrow.
    intros [[z|a]|a]; reflexivity.
  Defined.

  (** Now let's assume [f] is quasi-idempotent, but not necessarily using the same witness of pre-idempotency. *)
  Context (Ip : IsPreIdempotent f) (Jp : @IsQuasiIdempotent _ f Ip).

  Definition I (Z : BAut Cantor)
  : (Z + Cantor) + Cantor <~> Z + Cantor
    := equiv_path _ _ (Ip Z)..1.

  Definition I0
  : Cantor + Cantor + Cantor + Cantor <~> Cantor + Cantor + Cantor
    := I (f (point (BAut Cantor))).

  (** We don't know much about [I0], but we can show that it maps the rightmost two summands to the rightmost one, using the naturality of [I].  Here is the naturality. *)
  Definition Inat (Z Z' : BAut Cantor) (e : Z <~> Z')
  : I Z' oE (e +E 1 +E 1)
    = (e +E 1) oE I Z.
  Proof.
    revert e; equiv_intro (equiv_path Z Z') q.
    revert q; equiv_intro ((equiv_path_sigma_hprop Z Z')^-1) p.
    simpl. rewrite <- ap_ff, <- ap_f.
    unfold I. refine ((equiv_path_pp _ _)^ @ _ @ (equiv_path_pp _ _)).
    apply ap.
    refine ((pr1_path_pp (ap (f o f) p) (Ip Z'))^ @ _ @ pr1_path_pp _ _).
    apply ap. apply (concat_Ap Ip).
  Qed.

  (** To show our claim about the action of [I0], we will apply this naturality to the flip automorphism of [Cantor + Cantor].  Here are the images of that automorphism under [f] and [f o f]. *)
  Definition f_flip :=
    equiv_sum_symm Cantor Cantor +E equiv_idmap Cantor.
  Definition ff_flip :=
    (equiv_sum_symm Cantor Cantor +E equiv_idmap Cantor) +E (equiv_idmap Cantor).

  (** The naturality of [I] implies that [I0] commutes with these images of the flip. *)
  Definition I0nat_flip
        (x : ((Cantor + Cantor) + Cantor) + Cantor)
  : I0 (ff_flip x) = f_flip (I0 x)
    := ap10_equiv
         (Inat (f (point (BAut Cantor))) (f (point (BAut Cantor)))
               (equiv_sum_symm Cantor Cantor))
         x.

  (** The value of this is that we can detect which summand an element is in depending on whether or not it is fixed by [f_flip] or [ff_flip]. *)
  Definition f_flip_fixed_iff_inr (x : Cantor + Cantor + Cantor)
  : (f_flip x = x) <-> is_inr x.
  Proof.
    split; intros p; destruct x as [[c|c]|c]; simpl in p.
    - apply path_sum_inl in p.
      elim (inl_ne_inr _ _ p^).
    - apply path_sum_inl in p.
      elim (inl_ne_inr _ _ p).
    - exact tt.
    - elim p.
    - elim p.
    - reflexivity.
  Defined.

  Definition ff_flip_fixed_iff_inr
        (x : Cantor + Cantor + Cantor + Cantor)
  : (ff_flip x = x) <-> (is_inr x + is_inl_and is_inr x).
  Proof.
    split; intros p; destruct x as [[[c|c]|c]|c]; simpl in p.
    - do 2 apply path_sum_inl in p.
      elim (inl_ne_inr _ _ p^).
    - do 2 apply path_sum_inl in p.
      elim (inl_ne_inr _ _ p).
    - exact (inr tt).
    - exact (inl tt).
    - destruct p as [e|e]; elim e.
    - destruct p as [e|e]; elim e.
    - destruct p as [e|_]; [ elim e | reflexivity ].
    - destruct p as [_|e]; [ reflexivity | elim e ].
  Defined.

  (** And the naturality guarantees that [I0] preserves fixed points. *)
  Definition I0_fixed_iff_fixed
        (x : Cantor + Cantor + Cantor + Cantor)
  : (ff_flip x = x) <-> (f_flip (I0 x) = I0 x).
  Proof.
    split; intros p.
    - refine ((I0nat_flip x)^ @ ap I0 p).
    - apply (equiv_inj I0).
      refine (I0nat_flip x @ p).
  Defined.

  (** Putting it all together, here is the proof of our claim about [I0]. *)
  Definition I0_preserves_inr
        (x : Cantor + Cantor + Cantor + Cantor)
  : (is_inr x + is_inl_and is_inr x) <-> is_inr (I0 x).
  Proof.
    refine (iff_compose _ (f_flip_fixed_iff_inr (I0 x))).
    refine (iff_compose _ (I0_fixed_iff_fixed x)).
    apply iff_inverse, ff_flip_fixed_iff_inr.
  Defined.

  (** Now we bring quasi-idempotence into play. *)
  Definition J (Z : BAut Cantor)
  : I Z +E 1
    = I (f Z).
  Proof.
    unfold I; simpl.
    refine ((ap_f (Ip Z))^ @ _).
    do 2 apply ap.
    apply Jp.
  Defined.

  (** We reach a contradiction by showing that the two maps which [J] claims are equal send elements of the third summand of the domain into different summands of the codomain. *)
  Definition impossible : Empty.
  Proof.
    pose (x := inl (inr (fun n => true))
               : ((f (point (BAut Cantor))) + Cantor) + Cantor).
    apply (not_is_inl_and_inr' (I (f (point (BAut Cantor))) x)).
    - exact (transport is_inl
                       (ap10_equiv (J (point (BAut Cantor))) x) tt).
    - exact (fst (I0_preserves_inr x) (inr tt)).
  Defined.

End Assumptions.
End BAut_Cantor_Idempotent.

(** Let's make the important conclusions available globally. *)

Definition baut_cantor_idem `{Univalence}
: BAut Cantor -> BAut Cantor
  := BAut_Cantor_Idempotent.f.

Definition preidem_baut_cantor_idem `{Univalence}
: IsPreIdempotent baut_cantor_idem
  := BAut_Cantor_Idempotent.preidem_f.

Definition not_qidem_baut_cantor_idem `{Univalence}
: ~ { I : IsPreIdempotent baut_cantor_idem
        & IsQuasiIdempotent baut_cantor_idem }
  := fun IJ => BAut_Cantor_Idempotent.impossible IJ.1 IJ.2.


Require Import VST.floyd.proofauto.
Require Import VST.progs.even.

#[export] Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Definition odd_spec :=
 DECLARE _odd
  WITH z : Z, b: unit
  PRE [ tuint]
    PROP(0 <= z <= Int.max_signed) PARAMS(Vint (Int.repr z)) SEP()
  POST [ tint ]
    PROP() RETURN(Vint (if Z.odd z then Int.one else Int.zero)) SEP().

Definition even_spec :=
 DECLARE _even
  WITH z : Z
  PRE [ tuint]
    PROP(0 <= z <= Int.max_signed) PARAMS(Vint (Int.repr z)) SEP()
  POST [ tint ]
    PROP() RETURN (Vint (if Z.even z then Int.one else Int.zero)) SEP().

Definition main_spec :=
 DECLARE _main
  WITH gv : globals
  PRE  [] main_pre prog tt gv
  POST [ tint ]
    PROP() RETURN (Vint (if Z.even 42 then Int.one else Int.zero)) SEP(has_ext tt).


(* Before loading Program, check non-anomaly on missing library Program *)

Fail Program Definition f n (e:n=n): {n|n=0} := match n,e with 0, refl => 0 | _, _ => 0 end.

(* Then we test Program properly speaking *)

Require Import Arith Program.
Require Import ZArith Zwf.

Set Implicit Arguments.
(* Set Printing All. *)
Print sigT_rect.
Obligation Tactic := program_simplify ; auto with *.
About MR.

Program Fixpoint merge (n m : nat) {measure (n + m) (lt)} : nat :=
  match n with
    | 0 => 0
    | S n' => merge n' m
  end.

Print merge.

Print Z.lt.
Print Zwf.

Local Open Scope Z_scope.

Program Fixpoint Zwfrec (n m : Z) {measure (n + m) (Zwf 0)} : Z :=
  match n ?= m with
    | Lt => Zwfrec n (Z.pred m)
    | _ => 0
  end.

Next Obligation.
  red. Admitted.

Close Scope Z_scope.

Program Fixpoint merge_wf (n m : nat) {wf lt m} : nat :=
  match n with
    | 0 => 0
    | S n' => merge n' m
  end.

Print merge_wf.

Program Fixpoint merge_one (n : nat) {measure n} : nat :=
  match n with
    | 0 => 0
    | S n' => merge_one n'
  end.

Print Hint well_founded.
Print merge_one. Eval cbv delta [merge_one] beta zeta in merge_one.

Import WfExtensionality.

Lemma merge_unfold n m : merge n m =
  match n with
    | 0 => 0
    | S n' => merge n' m
  end.
Proof. intros. unfold merge at 1. unfold merge_func.
  unfold_sub merge (merge n m).
  simpl. destruct n ; reflexivity.
Qed.

Print merge.

Require Import Arith.
Unset Implicit Arguments.

Time Program Fixpoint check_n  (n : nat) (P : { i | i < n } -> bool) (p : nat)
  (H : forall (i : { i | i < n }), i < p -> P i = true)
  {measure (n - p)} :
  Exc (forall (p : { i | i < n}), P p = true) :=
  match le_lt_dec n p with
  | left _ => value _
  | right cmp =>
      if dec (P p) then
        check_n n P (S p) _
      else
        error
  end.

Require Import Omega Setoid.

Next Obligation.
  intros ; simpl in *. apply H.
  simpl in * ; omega.
Qed.

Next Obligation. simpl in *; intros.
  revert H0 ; clear_subset_proofs. intros.
  case (le_gt_dec p i) ; intro. simpl in *. assert(p = i) by omega. subst.
  revert H0 ; clear_subset_proofs ; tauto.

  apply H. simpl. omega.
Qed.

Program Fixpoint check_n'  (n : nat) (m : {m:nat | m = n}) (p : nat) (q:{q : nat | q = p})
  {measure (p - n) p} : nat :=
  _.


Require Import GeoCoq.Axioms.parallel_postulates.
Require Import GeoCoq.Tarski_dev.Ch13_1.

Section alternate_interior_angles_playfair_bis.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma alternate_interior__playfair_aux : alternate_interior_angles_postulate ->
   forall A1 A2 B1 B2 C1 C2 P,
   Perp2 A1 A2 B1 B2 P -> ~ Col A1 A2 P -> Col P B1 B2 -> Coplanar A1 A2 B1 B2 ->
   Par A1 A2 C1 C2 -> Col P C1 C2 ->
   Col C1 B1 B2. (** "half" of playfair_bis *)
Proof.
  intros aip A1 A2 B1 B2 C1 C2 P HPerp2 HNC1 HPB HCop HParAC HPC.
  elim(eq_dec_points P C1).
    intro; subst C1; auto.
  intro.
  assert(HParAB : Par A1 A2 B1 B2).
    {
    assert (Par_strict A1 A2 B1 B2); [|Par].
    apply (par_not_col_strict _ _ _ _ P); Col.
    apply par_symmetry.
    destruct HPerp2 as [X [Y [HCol1 [HPerp1 HPerp2]]]].
    assert (HI1 := HPerp1); assert (HI2 := HPerp2).
    destruct HI1 as [I1 H1]; destruct HI2 as [I2 H2].
    apply perp_in_col in H1; apply perp_in_col in H2.
    destruct H1 as [HCol2 HCol3]; destruct H2 as [HCol4 HCol5].
    assert (P = I2); [|treat_equalities; rename I1 into R].
      {
      elim (perp_not_col2 _ _ _ _ (perp_sym _ _ _ _ HPerp2)); intro;
      [apply l6_21 with B1 B2 X Y|apply l6_21 with B1 B2 Y X]; assert_diffs; Col.
      }
    elim (eq_dec_points P R); intro HNE; treat_equalities; [exfalso; Col|].
    apply (l12_9 _ _ _ _ X Y); Perp; apply coplanar_perm_16;
    apply col2_cop__cop with P R; try solve [assert_diffs; ColR];
    apply coplanar_perm_2;
    [apply col_cop__cop with A2|apply col_cop__cop with A1|
     apply col_cop__cop with A2|apply col_cop__cop with A1];
    Col; try solve [assert_diffs; auto]; apply coplanar_perm_16;
    [apply col_cop__cop with B2|apply col_cop__cop with B2|
     apply col_cop__cop with B1|apply col_cop__cop with B1];
    assert_diffs; Col; Cop.
    }
  elim(col_dec P A1 A2).
    { intro.
      assert_diffs.
      apply (not_strict_par _ _ _ _ P) in HParAB; Col.
      apply (not_strict_par _ _ _ _ P) in HParAC; Col.
      spliter.
      ColR.
    }
    intro HStrict.
    apply (par_not_col_strict _ _ _ _ P) in HParAB; Col.
    apply (par_not_col_strict _ _ _ _ P) in HParAC; Col.
    destruct HPerp2 as [P1 [P2 [HP [HPerpAP HPerpBP]]]].
    assert(HQ := HPerpAP); auto.
    destruct HQ as [Q [_ [_ [HQP[HQL _]]]]].
    assert(HP' := HPerpBP); auto.
    destruct HP' as [P' HPerpP].
    assert(P'=P) by (apply (l8_14_2_1b _ P1 P2 B1 B2); Col).
    subst P'.
    destruct HPerpP as [_ [_ [HPP _]]].
    assert(P<>Q) by (intro; subst Q; auto).
    apply (perp_col0 _ _ _ _ P Q) in HPerpAP; Col.
    apply (perp_col0 _ _ _ _ P Q) in HPerpBP; Col.
    clear dependent P1.
    clear dependent P2.

    assert(~ Col Q C1 P)
      by (apply (par_not_col A1 A2); auto;
          apply (par_strict_col_par_strict _ _ _ C2); Col).
    assert_diffs.
    assert(HB3 : exists B3, Col B1 B2 B3 /\ B3 <> P).
    { elim(eq_dec_points B1 P).
      intro; subst B1; exists B2; Col.
      intro; exists B1; Col.
    }
    destruct HB3 as [B3 []].
    assert(Col P C1 B3); [|ColR].
    assert_diffs.
    apply (cop_perp2__col _ _ _ P Q); auto; [| |apply (perp_col2 B1 B2); Col].
    assert (Coplanar A1 A2 P B3) by (apply col2_cop__cop with B1 B2; Col; Cop).
    assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
    assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
    assert (Coplanar A1 A2 P Q) by (apply coplanar_perm_1, col__coplanar; Col).
    CopR.
    apply perp_left_comm.
    apply per_perp; auto.

    assert(HA3 : exists A3, Col A1 A2 A3 /\ TS P Q C1 A3).
    { elim(col_dec P Q A1);
      [|intro; apply (cop_not_par_other_side _ _ _ _ Q); Col].

      {
      intro.
      assert(HA3 := cop_not_par_other_side P Q A2 A1 Q C1).
      destruct HA3 as [A3 []]; Col; [intro; apply HStrict; ColR| |].
      assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
      assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
      assert (Coplanar A1 A2 P Q) by (apply coplanar_perm_1, col__coplanar; Col).
      CopR.
      exists A3; split; Col.
      }

      {
      assert (Coplanar A1 A2 C1 C2) by (apply pars__coplanar; auto).
      assert (Coplanar A1 A2 P C1) by (apply col2_cop__cop with C1 C2; Col; Cop).
      assert (Coplanar A1 A2 P Q) by (apply coplanar_perm_1, col__coplanar; Col).
      CopR.
      }

    }
    destruct HA3 as [A3 [HA3 Hts]].
    assert(~ Col A3 P Q) by (destruct Hts as [_ []]; auto).
    assert_diffs.
    apply (l11_17 A3 Q P).
    apply perp_per_1; auto; apply (perp_col2 A1 A2); Col.
    apply conga_sym.
    apply aip; auto.
    apply (par_col4__par C1 C2 A1 A2); Col.
    apply par_strict_par; Par.
Qed.

Lemma alternate_interior__playfair_bis : alternate_interior_angles_postulate -> alternative_playfair_s_postulate.
Proof.
intros aia.
intros A1 A2 B1 B2 C1 C2 P HPerp2 HPB HCop HParAC HPC.
split.
apply (alternate_interior__playfair_aux aia A1 A2 _ _ _ C2 P); auto.
apply (alternate_interior__playfair_aux aia A1 A2 _ _ _ C1 P); Col; Par.
Qed.

End alternate_interior_angles_playfair_bis.


(**************************************************************************)
(*  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.               *)
(**************************************************************************)

(** Class of "Strict Kleene Algebras" : those without a zero;
   extension of the [kleene_reflexivity] tactic to these structures,
   using a faithful embedding. *)

Require Import Common.
Require Import Classes.
Require Import DecideKleeneAlgebra.
Set Implicit Arguments.
Unset Printing Implicit Defensive.

Bind Scope SA_scope with X.

(** Strict Kleene Algebras operations *)
Class SKA_Ops (G: Graph) := {
  dot:  forall A B C, X A B -> X B C -> X A C;
  one:  forall A,     X A A;
  plus: forall A B, X A B -> X A B -> X A B;
  star: forall A, X A A -> X A A;
  leq:  forall A B: T, relation (X A B) := fun A B x y => equal A B (plus A B x y) y
}.

Notation "x == y"  := (equal _ _ x y) (at level 70): SA_scope.
Notation "x <== y" := (leq _ _ x y) (at level 70): SA_scope.
Notation "x * y"   := (dot _ _ _ x y) (at level 40, left associativity): SA_scope.
Notation "x + y"   := (plus _ _ x y) (at level 50, left associativity): SA_scope.
Notation "x #"     := (star _ x) (at level 15, left associativity): SA_scope.
Notation "1"       := (one _): SA_scope.

Close Scope A_scope.
Open Scope SA_scope.
Delimit Scope SA_scope with SA.

(** Strict Kleene Algebras axioms *)
Class StrictKleeneAlgebra {G: Graph} {Ops: SKA_Ops G} := {
  dot_compat:>
    forall A B C, Proper (equal A B ==> equal B C ==> equal A C) (dot A B C);
  plus_compat:>
    forall A B, Proper (equal A B ==> equal A B ==> equal A B) (plus A B);
  dot_assoc: forall A B C D (x: X A B) y (z: X C D), x*(y*z) == (x*y)*z;
  dot_neutral_left:  forall A B (x: X A B), 1*x == x;
  dot_neutral_right:  forall A B (x: X A B), x*1 == x;
  plus_idem: forall A B (x: X A B), x+x == x;
  plus_assoc: forall A B (x y z: X A B), x+(y+z) == (x+y)+z;
  plus_com: forall A B (x y: X A B), x+y == y+x;
  dot_distr_left:  forall A B C (x y: X A B) (z: X B C), (x+y)*z == x*z + y*z;
  dot_distr_right: forall A B C (x y: X B A) (z: X C B), z*(x+y) == z*x + z*y;
  star_make_left: forall A (a:X A A), 1 + a#*a == a#;
  star_destruct_left: forall A B (a: X A A) (c: X A B), a*c <== c  ->  a#*c <== c;
  star_destruct_right: forall A B (a: X A A) (c: X B A), c*a <== c  ->  c*a# <== c
}.
Arguments StrictKleeneAlgebra G {Ops}.

(** Lifting an equivalence relation to option types  *)

Section oe.
  Variable A: Type.
  Variable R: relation A.
  Inductive oequal: relation (option A) :=
  | oe_some: forall x y, R x y -> oequal (Some x) (Some y)
  | oe_none: oequal None None.
  Hypothesis HR: Equivalence R.
  Lemma oequal_equivalence: Equivalence oequal.
  Proof.
    constructor.
     intros [x|]; constructor. reflexivity.
     intros x y [x' y' H|]; constructor. symmetry. assumption.
     intros x y z [x' y' H|] H'; trivial.
      inversion_clear H'. constructor. rewrite H. assumption.
  Qed.
End oe.

Unset Strict Implicit.

(** Definition of the faithful embedding from Strict Kleene Algebras
   to Kleene Algebras *)

Section F.
  Context G Ops `{@StrictKleeneAlgebra G Ops}.

  Program Instance oGraph: Graph := {
    T := T;
    X A B := option (X A B);
    equal A B := oequal (equal A B)
  }.
  Obligation 1.
    intros. apply oequal_equivalence, G.
  Defined.

  Definition inj A B (x: @X G A B): @X oGraph A B := Some x.
  Lemma faithful: forall A B (x y: X A B), inj x == inj y -> x == y.
  Proof.
    intros A B x y Hxy. inversion_clear Hxy. assumption.
  Qed.

  Global Instance oMonoid_Ops: Monoid_Ops oGraph := {
    dot A B C x y :=
      match x,y with
        | Some x, Some y => Some (x*y)
        | _,_ => None
      end;
    one A := Some 1
  }.

  Global Instance oSemiLattice_Ops: SemiLattice_Ops oGraph := {
    plus A B x y :=
      match x,y with
        | None,y => y
        | x,None => x
        | Some x, Some y => Some (x+y)
      end;
    zero A B := None
  }.

  Global Instance oStar_Op: Star_Op oGraph := {
    star A x :=
      match x with
        | None => Some 1
        | Some x => Some (x#)
      end
  }.

  Instance oMonoid: Monoid oGraph.
  Proof.
    constructor; intros.
     intros _ _ [x x' Hx|] _ _ [y y' Hy|]; simpl; constructor.
      apply dot_compat; assumption.
     destruct x; try constructor.
      destruct y; try constructor.
       destruct z; constructor. apply dot_assoc.
     destruct x; simpl; constructor. apply dot_neutral_left.
     destruct x; simpl; constructor. apply dot_neutral_right.
  Qed.

  Instance oSemiLattice: SemiLattice oGraph.
  Proof.
    constructor; intros.
     intros _ _ [x x' Hx|] _ _ [y y' Hy|]; simpl; constructor; trivial.
      apply plus_compat; assumption.
     destruct x; simpl; constructor. reflexivity.
     destruct x; simpl; constructor. apply plus_idem.
     destruct x; destruct y; destruct z; simpl; constructor; try reflexivity.
      apply plus_assoc.
     destruct x; destruct y; simpl; constructor; try reflexivity.
      apply plus_com.
  Qed.

  Instance oIdemSemiRing: IdemSemiRing oGraph.
  Proof.
    constructor; eauto with typeclass_instances; intros.
     destruct x; reflexivity.
     destruct x; destruct y; destruct z; simpl; constructor; try reflexivity.
      apply dot_distr_left.
     destruct x; destruct y; destruct z; simpl; constructor; try reflexivity.
      apply dot_distr_right.
  Qed.

  Global Instance oKleeneAlgebra: KleeneAlgebra oGraph.
  Proof.
    constructor; eauto with typeclass_instances.
     intros A [a|]; simpl; constructor; try reflexivity.
      apply star_make_left.
     intros A B [a|] [c|] Hac; simpl in *; try constructor.
      apply star_destruct_left. inversion_clear Hac. assumption.
      rewrite dot_neutral_left. apply plus_idem.
     intros A B [a|] [c|] Hac; simpl in *; try constructor.
      apply star_destruct_right. inversion_clear Hac. assumption.
      rewrite dot_neutral_right. apply plus_idem.
  Qed.
End F.

(** The exported tactic embeds the goal in Kleene algebras and calls [kleene_reflexivity] *)
Ltac skleene_reflexivity :=
  (* [parse] converts an expression of strict Kleene algebras into an expression of Kleene algebras *)
  let rec parse t :=
    match t with
      | @dot ?G ?O ?A ?B ?C ?x ?y =>
        let x := parse x in
        let y := parse y in
          constr:(@Classes.dot (@oGraph G) (@oMonoid_Ops G O) A B C x y)
      | @one ?G ?O ?A =>
          constr:(@Classes.one (@oGraph G) (@oMonoid_Ops G O) A)
      | @plus ?G ?O ?A ?B ?x ?y =>
        let x := parse x in
        let y := parse y in
          constr:(@Classes.plus (@oGraph G) (@oSemiLattice_Ops G O) A B x y)
      | @star ?G ?O ?A ?x =>
        let x := parse x in
          constr:(@Classes.star (@oGraph G) (@oStar_Op G O) A x)
      | _ => constr:(inj t)
    end
  in
  unfold leq;
  lazymatch goal with
    | |- @equal ?G ?A ?B ?x ?y =>
      let x := parse x in
      let y := parse y in
        apply faithful; change (@equal (@oGraph G) A B x y); kleene_reflexivity
  end.

(*begintests
Section t.
  Context `{StrictKleeneAlgebra}.
  Lemma test: forall A B (a: X A B) (b: X B A), a*(b*a)# == (a*b)#*a.
  Proof.
    intros.
    skleene_reflexivity.
  Qed.
  Lemma test': forall A (a b: X A A), (a+b+1)# == a#*(b*a#)#.
  Proof.
    intros.
    skleene_reflexivity.
  Qed.
  Lemma test'': forall A (a b: X A A), (a*a+b)# <== a#*(b*a#)#.
  Proof.
    intros.
    skleene_reflexivity.
  Qed.
  Lemma test''': forall A (a b: X A A), (a*a+b)# <== a*(b*a#)#.
  Proof.
    intros.
    try skleene_reflexivity.
  Abort.
End t.
endtests*)


From Fiat.Narcissus Require Import Examples.TutorialPrelude.

Record msg := { data : list (word 8) }.
Definition format :=
  format_nat 8 ◦ length ◦ data ++
  format_list format_word ◦ data.
Definition invariant (_ : msg) := True.

Definition dec : CorrectAlignedDecoderFor invariant format.
Proof.
  synthesize_aligned_decoder.
Defined.


(************************************************************************************)
(**                                                                                *)
(**                             The SQLEngines Library                              *)
(**                                                                                *)
(**            LRI, CNRS & Université Paris-Sud, Université Paris-Saclay            *)
(**                                                                                *)
(**                        Copyright 2016-2019 : FormalData                         *)
(**                                                                                *)
(**         Authors: Véronique Benzaken                                             *)
(**                  Évelyne Contejean                                              *)
(**                  Chantal Keller                                                 *)
(**                  Eunice-Raquel Martins                                          *)
(**                                                                                *)
(************************************************************************************)

Require Import List.
Require Import OrderedSet Signatures Filter NestedLoop.

Set Implicit Arguments.

Module ThetaNestedLoop.
Section Sec.

Hypotheses o1 o2 o : Type.
Hypothesis O1 : Oeset.Rcd o1.
Hypothesis O2 : Oeset.Rcd o2.
Hypothesis O : Oeset.Rcd o.

Hypothesis build_ : o1 -> o2 -> o.
Hypothesis build_eq_1  :
  forall x1 x1' x2,
    Oeset.compare O1 x1 x1' = Eq -> Oeset.compare O (build_ x1 x2) (build_ x1' x2) = Eq.
Hypothesis build_eq_2  :
  forall x1 x2 x2',
    Oeset.compare O2 x2 x2' = Eq -> Oeset.compare O (build_ x1 x2) (build_ x1 x2') = Eq.

Hypothesis theta : o -> bool.
Hypothesis theta_eq : forall x y, Oeset.compare O x y = Eq -> theta x = theta y.

Hypothesis C1 : Cursor.Rcd O1.
Hypothesis C2 : Cursor.Rcd O2.

Definition build : Cursor.Rcd O :=
  Filter.build _ theta_eq (NestedLoop.build O _ build_eq_1 build_eq_2 C1 C2).

End Sec.

End ThetaNestedLoop.


Require Import
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.Narcissus.Common.Specs.

Unset Implicit Arguments.

Section Bool.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : QueueMonoidOpt monoid bool}.

  Definition format_bool (b : bool) (ctx : CacheFormat) :=
    ret (enqueue_opt b mempty, addE ctx 1).

  Definition decode_bool (b : B) (ctx : CacheDecode) : option (bool * B * CacheDecode) :=
    Ifopt dequeue_opt b as decoded Then Some (decoded, addD ctx 1) Else None.

  Theorem bool_decode_correct
          {P : CacheDecode -> Prop}
          (P_OK : cache_inv_Property P (fun P => forall b cd, P cd -> P (addD cd b)))
    :
      CorrectDecoder monoid (fun _ => True)
                              (fun _ _ => True)
                              format_bool decode_bool P.
  Proof.
    unfold CorrectDecoder, format_bool, decode_bool; split.
    - intros env env' xenv w w' ext ? Eeq _ _ Penc.
      computes_to_inv; injections.
      unfold If_Opt_Then_Else.
      erewrite dequeue_mappend_opt;
      try apply dequeue_head_opt.
      rewrite mempty_left.
      injections; eexists; split; eauto using add_correct.
    - intros;
        destruct (dequeue_opt bin) as [ [? ?] | ] eqn: ? ;
        simpl in *; try discriminate; injections; intuition.
     eexists; eexists; repeat split.
     eapply dequeue_opt_inj; eauto.
     rewrite <- (mempty_left ext) at -1;
       auto using dequeue_mappend_opt, dequeue_head_opt.
     apply add_correct; eauto.
  Qed.

End Bool.


From isla Require Import opsem.

Definition a18270 : isla_trace :=
  Smt (DeclareConst 68%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
  Smt (DefineConst 69%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 68%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 69%Z)) Mk_annot :t:
  tnil
.