Require Import Coq.Program.Equality.
From Coq.Logic Require Import JMeq EqdepFacts.
From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category.

Open Scope equiv_scope.

Set Universe Polymorphism.

Structure Functor (C D : Category) : Type :=
  {
    FApp : Obj C -> Obj D;
    FAppH : forall {X Y : Obj C}, Hom X Y -> Hom (FApp X) (FApp Y);

    (* Conditions *)
    FAppH_comp_eq : forall {X Y Z : Obj C} (f : Hom Y Z) (g : Hom X Y), FAppH (f \o g) = (FAppH f) \o (FAppH g);
    Functor_id_eq : forall {X : Obj C}, FAppH (\Id X) = \Id (FApp X)
  }.

Global Arguments FApp {C D}.
Global Arguments FAppH {C D} f {X Y}.
Global Arguments FAppH_comp_eq {C D} f {X Y Z}.

Lemma ToFunctorEq :
  forall {C D : Category} (F G : Functor C D),
    (forall {X Y : Obj C} (f : Hom X Y), Hom_eq' (FAppH F f) (FAppH G f)) ->
    F = G.
Proof.
  move => C D.
  case => AppF AppHF compeqF ideqF.
  case => AppG AppHG compeqG ideqG.
  rewrite /=.
  move => cond.
  have: AppF = AppG.
  {
    apply: functional_extensionality.
    move => X.
    move: (cond X X (\Id X)).
    case.
    by [].
  }
  move => eqApp.
  subst.
  have: AppHF = AppHG.
  {
    apply: functional_extensionality_dep => X.
    apply: functional_extensionality_dep => Y.
    apply: functional_extensionality => f.
    case: (cond _ _ f).
    move => eqX.
    case.
    move => eqY.
    repeat rewrite HomId'_id.
    rewrite Hom_IdL.
    rewrite Hom_IdR.
    by [].
  }
  move => eqApp.
  subst.
  have: (compeqF = compeqG /\ ideqF = ideqG).
  {
    split; exact: p_proof_irrelevance.
  }
  case.
  move =>-> =>->.
  by [].
Qed.


Require Import SystemF.
Require Import List.
Require Import Utils.
Require Import Bisimulation.

Section Total.

  Variable Delta : nat -> Term.
  Variable Xi : nat -> Ty.
  Variable Prog : forall n l m, Derivation Xi [n ; l |= F m @ Xi m] -> Derivation Xi [n ; l |= Delta m @ Xi m].
  Variable ProgTy : forall m, valid (Xi m) 0.

  Inductive Total : Holds -> Set :=
  | total_derivation : forall n l t A, Derivation Xi [n ; l |= t @ A] -> Total [n ; l |= t @ A]


Require Import Arith.
Require Import Ascii.
Require Import Nat.
Require Import Bool.
Require Import Coq.Strings.Byte.
Require Import Strings.String.
Scheme Equality for string.
Local Open Scope string_scope.

(* Tipul de date Nat *)

Inductive Nat : Type :=
| TypeNat : nat -> Nat
| ErrorNat : Nat.

Scheme Equality for Nat.

(* Tipul de date Bool *)

Inductive Bool : Type :=
| TypeBool : bool -> Bool
| ErrorBool : Bool.

(* Tipul de date String *)

Inductive String : Type :=
| TypeString : string -> String
| ErrorString : String.

Coercion TypeNat : nat >-> Nat.
Coercion TypeBool : bool >-> Bool.
Coercion TypeString : string >->String.

(* Tipul list *)

Inductive list (T : Type) : Type :=
| nil
| cons (t : T) (l : list T).

Check cons Nat 4 (cons Nat 3 (nil Nat)).
Check cons Bool false (cons Bool true (nil Bool)).

Arguments nil {T}.
Notation "[]" := nil.
Notation "{ X , .. , Y }" := (cons Nat X .. (cons Nat Y []) ..).
Notation "{ X ; .. ; Y }" := (cons Bool X .. (cons Bool Y []) ..).
Notation "{ X ;;; .. ;;; Y }" := (cons String X .. (cons String Y []) ..).

Check {1, 2, 3}.
Check {false; true; true; false}.

Definition list1nat := {1, 3, 5, 7, 9}.
Definition list2nat := {2, 4, 6, 8, 10, 12, 14}.
Definition list3nat := {10, 20}.
Definition list1bool := {true; false; true; false; false}.
Definition list2bool := {true; false; true; false; false; true; false}.
Definition list1string := { "ioan" ;;; "ioana" ;;; "dan"}.
Definition list2string := { "baiat" ;;; "fata" ;;; "baiat" }.

(* Tipul array *)

Inductive Array : Type :=
| NatArray : list Nat -> Array
| BoolArray : list Bool -> Array
| StringArray : list String -> Array
| Matrix : list Array -> Array.

Check NatArray list1nat.
Check BoolArray list1bool.

Notation "{ X & .. & Y }" := (cons Array X .. (cons Array Y []) ..).
Notation "'[Natural]' = L " := (NatArray L) (at level 80).
Notation "'[Boolean]' = L " := (BoolArray L) (at level 80).
Notation "'[String]' = L " := (StringArray L) (at level 80).
Notation "'[[Matrix]]' = L" := (Matrix L) (at level 20).

Check Matrix { (NatArray list1nat) & (NatArray list2nat) }.

Definition vector_nat := [Natural] = list1nat.
Definition vector_bool := [Boolean] = list1bool.
Definition vector_string := [String] = list1string.
Definition matrix_both := [[Matrix]] = { vector_nat & vector_bool }.

Compute vector_nat.
Compute vector_bool.
Compute vector_string.

(* Tipuri acceptate pentru struct *)

Inductive types_allowed : Type :=
| natural (n : Nat)
| boolean (b : Bool)
| stringg (s : String)
| arr (v : Array)
| inexistent.

Coercion  natural : Nat >-> types_allowed.
Coercion boolean : Bool >-> types_allowed.
Coercion arr : Array >-> types_allowed.
Coercion stringg : String >-> types_allowed.

Check 7 : types_allowed.
Check false : types_allowed.

(* Perechi pentru struct *)

Inductive pair_struct : Type :=
| pair (first : string) (second : types_allowed).

Notation "( N , V )" := (pair N V).
Notation "{ P1 ;; .. ;; P2 }" := (cons pair_struct P1 .. (cons pair_struct P2 []) ..).

(* Tipul struct *)

Inductive Struct : Type :=
| struct_cons ( struct_pairs : list pair_struct).

(* Tipul map *)

Inductive MapTypes :=
| natstring (kn : list Nat) (vs : list String)
| stringnat (ks : list String) (vn : list Nat)
| natnat (kn : list Nat) (vn : list Nat)
| stringstring (ks : list String) (vs : list String).

Definition map1 := natnat list1nat list1nat.
Definition map2 := natstring list3nat list1string.

(* Tipurile de date *)

Inductive Types : Type :=
| Nats (n : Nat)
| Bools (b : Bool)
| Strings (s: String)
| undeclared : Types
| unassignedNat : Types
| unassignedBool : Types
| unassignedString : Types
| unassignedArray : Types
| unassignedStruct : Types
| unassignedMap : Types
| Arrays (v : Array)
| Structs (s : Struct)
| Maps (m : MapTypes)
| Error.

Definition Env := string -> Types.
Coercion Nats : Nat >-> Types.
Coercion Bools : Bool >-> Types.
Coercion Strings : String >-> Types.
Coercion Arrays : Array >-> Types.
Coercion Maps : MapTypes >-> Types.

(* Expresiile aritmetice si boolene *)

Inductive Exp :=
| anum : Nat -> Exp
| avar : string -> Exp
| str : String -> Exp
| aplus : Exp -> Exp -> Exp
| aminus : Exp -> Exp -> Exp
| amul : Exp -> Exp -> Exp
| adiv : Exp -> Exp -> Exp
| amod : Exp -> Exp -> Exp
| btrue : Exp
| bfalse : Exp
| not' : Exp -> Exp
| and' : Exp -> Exp -> Exp
| or' : Exp -> Exp -> Exp
| less : Exp -> Exp -> Exp
| lessequal : Exp -> Exp -> Exp
| greater : Exp -> Exp -> Exp
| greaterequal : Exp -> Exp -> Exp
| equal : Exp -> Exp -> Exp
| notequal : Exp -> Exp -> Exp.

Coercion anum : Nat >-> Exp.
Coercion avar : string >-> Exp.

(* Notatii pentru Exp *)

Notation "A +' B" := (aplus A B) (at level 60, right associativity).
Notation "A -' B" := (aminus A B) (at level 58, left associativity).
Notation "A *' B" := (amul A B) (at level 58, left associativity).
Notation "A /' B" := (adiv A B) (at level 58, left associativity).
Notation "A %' B" := (amod A B) (at level 58, left associativity).
Notation "! A" := (not' A) (at level 75, right associativity).
Notation "A &&' B" := (and' A B) (at level 40, left associativity).
Notation "A ||' B" := (or' A B) (at level 50, left associativity).
Notation "A <' B" := (less A B) (at level 70, no associativity).
Notation "A <=' B" := (lessequal A B) (at level 70, no associativity).
Notation "A >' B" := (greater A B) (at level 70, no associativity).
Notation "A >=' B" := (greaterequal A B) (at level 70, no associativity).
Notation "A ==' B" := (equal A B) (at level 70, no associativity).
Notation "A !=' B" := (notequal A B) (at level 70, no associativity).

Check 2 +' 2.
Check 2 +' btrue.
Check (and' 2 2).

(* Statement-urile *)

Inductive Stmt : Type :=
| declareNat :  string -> Stmt
| declareBool :  string -> Stmt
| declareString :  string -> Stmt

| assignmentNat : string -> Exp -> Stmt
| assignmentBool : string -> Exp -> Stmt
| assignmentString : string -> Exp -> Stmt

| initializeNat : string -> Exp -> Stmt
| initializeBool : string -> Exp -> Stmt
| initializeString : string -> Exp -> Stmt

| sequence : Stmt -> Stmt -> Stmt
| ifthenelse : Exp -> Stmt -> Stmt -> Stmt
| ifthen : Exp -> Stmt -> Stmt
| while_loop : Exp -> Stmt -> Stmt
| for_loop : Stmt -> Exp -> Stmt -> Stmt -> Stmt
| empty : Stmt
| switch_case : Exp -> list pairs -> Stmt

(*for Array*)
| declareArrayNat : string -> Stmt
| declareArrayBool : string -> Stmt
| declareArrayString : string -> Stmt
| declareMatrix : string -> Stmt

| initializeArrayNat : string -> Array -> Stmt
| initializeArrayBool : string -> Array -> Stmt
| initializeArrayString : string -> Array -> Stmt
| initializeMatrix : string -> Array -> Stmt

| setElemArrayNat : string -> nat -> Nat -> Stmt
| setElemArrayBool : string -> nat -> Bool -> Stmt
| setElemArrayString : string -> nat -> String -> Stmt
| setElemMatrix : string -> nat -> Array -> Stmt

| pushNat : string -> Nat -> Stmt
| pushBool : string -> Bool -> Stmt
| pushString : string -> String -> Stmt
| pushMatrix : string -> Array -> Stmt

(*for Struct*)
| declareStruct : string -> Struct -> Stmt
| set_element_struct : string -> string -> types_allowed -> Stmt

(*for Map*)
| declareMap_nn : string -> MapTypes -> Stmt
| declareMap_ns : string -> MapTypes -> Stmt
| declareMap_sn : string -> MapTypes -> Stmt
| declareMap_ss : string -> MapTypes -> Stmt
| addToMap_nn : string -> Nat -> Nat -> Stmt
| addToMap_ns : string -> Nat -> String -> Stmt
| addToMap_sn : string -> String -> Nat -> Stmt
| addToMap_ss : string -> String -> String -> Stmt

with pairs : Type :=
| pair_default : Stmt -> pairs (*cazul implicit al switch-ului*)
| pair_other : Nat -> Stmt -> pairs.

(* Notatii pentru Stmt *)

Notation "'natural' S" := (declareNat S) (at level 79).
Notation "'boolean' S" := (declareBool S) (at level 79).
Notation "'char' S" := (declareString S) (at level 79).

Notation "S :n= E" := (assignmentNat S E) (at level 80).
Notation "S :b= E" := (assignmentBool S E) (at level 80).
Notation "S :s= E" := (assignmentString S E) (at level 80).

Notation "'Natural' S ::= E" := (initializeNat S E) (at level 79).
Notation "'Boolean' S ::= E" := (initializeBool S E) (at level 79).
Notation "'Char' S ::= E" := (initializeString S E) (at level 79).

Notation "S1 ;s; S2" := (sequence S1 S2 ) (at level 90).
Notation "'If' ( B ) 'Then' ( S1 ) 'Else' ( S2 ) 'EndIte'" := (ifthenelse B S1 S2) (at level 55).
Notation "'If' ( B ) 'Then' [ S ] 'EndI'" := (ifthen B S ) (at level 50).
Notation "'While' ( B ) [ S ] 'EndW'" := (while_loop B S) (at level 50).
Notation "'For' '(/' S1 ';f;' B ';f;' S2 '\)' '{/' S3 '\}'  'EndF'" := (for_loop S1 B S2 S3) (at level 50).

Notation "'default:{' S };" := (pair_default S) (at level 96).
Notation "'case(' E ):{ S };" := (pair_other E S) (at level 96).
Notation "switch( E ){ P1 ;sw; .. ;sw; Pn '}end'" := (switch_case E (cons pairs P1 .. (cons pairs Pn []) ..)) (at level 97).

Notation "[Natural] V" := (declareArrayNat V) (at level 79).
Notation "[Boolean] V" := (declareArrayBool V) (at level 79).
Notation "[String] V" := (declareArrayString V) (at level 79).
Notation "[[Matrix]] V" := (declareMatrix V) (at level 79).

Notation "[Natural_I] V :in:= L" := (initializeArrayNat V L) (at level 77).
Notation "[Boolean_I] V :ib:= L" := (initializeArrayBool V L) (at level 77).
Notation "[String_I] V :is:= L" := (initializeArrayString V L) (at level 77).
Notation "[[Matrix_I]] V :im:= L" := (initializeMatrix V L) (at level 77).

Notation "V [ P ] :n= L" := (setElemArrayNat V P L) (at level 78).
Notation "V [ P ] :b= L" := (setElemArrayBool V P L) (at level 78).
Notation "V [ P ] :s= L" := (setElemArrayString V P L) (at level 78).
Notation "V [ P ] :m= L" := (setElemMatrix V P L) (at level 78).

Notation "push_n( V ) X" := (pushNat V X) (at level 79).
Notation "push_b( V ) X" := (pushBool V X) (at level 79).
Notation "push_s( V ) X" := (pushString V X) (at level 79).
Notation "push_m( V ) X" := (pushMatrix V X) (at level 79).

Notation "struct( N ) L" := (declareStruct N L) (at level 79).
Notation "'setS' N '[(' F ')]' := V" := (set_element_struct N F V) (at level 79).

Notation "'Map' M :nn= L" := (declareMap_nn M L) (at level 79).
Notation "'Map' M :ns= L" := (declareMap_ns M L) (at level 79).
Notation "'Map' M :sn= L" := (declareMap_sn M L) (at level 79).
Notation "'Map' M :ss= L" := (declareMap_ss M L) (at level 79).
Notation "'add_nn' M '<-' K ':|:' V " := (addToMap_nn M K V) (at level 79).
Notation "'add_ns' M '<-' K ':|:' V" := (addToMap_ns M K V) (at level 79).
Notation "'add_sn' M '<-' K ':|:' V" := (addToMap_sn M K V) (at level 79).
Notation "'add_ss' M '<-' K ':|:' V" := (addToMap_ss M K V) (at level 79).

Notation "{ P1 ;sw; .. ;sw; Pn }" := (cons pairs P1 .. (cons pairs Pn []) ..).

(* Definirea unor enviroment-uri *)

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Definition update (env : Env)
           (x : string) (v : Types) : Env :=
  fun y => if (eqb_string y x)
           then v
           else (env y).

Definition all (x : Types) : Env :=
  (fun _ => x).

Definition default := all undeclared.

Definition default_zero (s : string) := update default s 0.
Check false.
Definition default_false (s : string) := update default s false.

Definition env1 := update default "v1" 1.
Definition env2 := update default "v2" true.

Check "v1".
Compute env2 "v2" .

(* Definirea operatiilor pentru elemente de tipul Types *)

Definition types_plus (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeNat(x + y)
| TypeBool x, TypeBool y => match x, y with
                    | true, true => TypeNat 2
                    | false, false => TypeNat 0
                    | _, _ => TypeNat 1
                    end
| TypeNat x, TypeBool y => match y with
                   | true => TypeNat (x + 1)
                   | false => TypeNat (x + 0)
                   end
| TypeBool x, TypeNat y => match x with
                   | true => TypeNat (1 + y)
                   | false => TypeNat (0 + y)
                   end
| _, _ => ErrorNat
end.

(* plus *)
(*
Definition types_plus (x y : Types) : Types :=
  match x, y with
    | Nats (TypeNat a), Nats (TypeNat b) => Nats (TypeNat (a + b))
    | _, _ => Nats (ErrorNat)
  end.

Compute (types_plus (Nats 8) (Nats 8)).*)

(* minus *)

Definition types_minus (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeNat(x - y)
| TypeBool x, TypeBool y => match x, y with
                    | true, false => TypeNat 1
                    | _, _ => TypeNat 0
                    end
| TypeNat x, TypeBool y => match y with
                   | true => TypeNat (x - 1)
                   | false => TypeNat x
                   end
| TypeBool x, TypeNat y => match x with
                   | true => TypeNat (1 - y)
                   | false => TypeNat (0 - y)
                   end
| _, _ => ErrorNat
end.

Check (types_minus true false).
Compute (types_minus true true).
Compute (types_minus 8 false).
Compute (types_minus 8 true).
Compute (types_minus 10 8).
Compute (types_minus false 2).
Compute (types_minus true 0).

(* inmultire *)

Definition types_mul (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeNat(x * y)
| TypeBool x, TypeBool y => match x, y with
                    | true, true => TypeNat 1
                    | _, _ => TypeNat 0
                    end
| TypeNat x, TypeBool y => match y with
                   | true => TypeNat x
                   | false => TypeNat 0
                   end
| TypeBool x, TypeNat y => match x with
                   | true => TypeNat y
                   | false => TypeNat 0
                   end
| _, _ => ErrorNat
end.

Compute (types_mul 4 2).
Compute (types_mul 4 true).
Compute (types_mul 4 false).
Compute (types_mul true true).
Compute (types_mul false true).

(* impartire *)

Definition types_div (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match y with
                          | 0 => ErrorNat
                          | _ => TypeNat(div x y)
                          end
| TypeBool x, TypeBool y => match x, y with
                            | true, true => TypeNat 1
                            | false, true => TypeNat 0
                            | _, _ => ErrorNat
                            end
| TypeNat x, TypeBool y => match y with
                           | true => TypeNat x
                           | false => ErrorNat
                           end
| TypeBool x, TypeNat y => match x, y with
                           | _, 0 => ErrorNat
                           | true, _ => TypeNat (div 1 y)
                           | false, _ => TypeNat 0
                           end
| _, _ => ErrorNat
end.

Compute (types_div 8 4).
Compute (types_div 8 0).
Compute (types_div 8 true).
Compute (types_div 8 false).
Compute (types_div true true).
Compute (types_div false true).

(* mod *)

Definition types_mod (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match y with
                          | 0 => ErrorNat
                          | _ => TypeNat(modulo x y)
                          end
| TypeBool x, TypeBool y => match x, y with
                            | true, true => TypeNat 0
                            | false, true => TypeNat 0
                            | _, _ => ErrorNat
                            end
| TypeNat x, TypeBool y => match y with
                           | true => TypeNat 0
                           | false => ErrorNat
                           end
| TypeBool x, TypeNat y => match x, y with
                           | _, 0 => ErrorNat
                           | true, _ => TypeNat (modulo 1 y)
                           | false, _ => TypeNat 0
                           end
| _, _ => ErrorNat
end.

Compute (types_mod 8 4).
Compute (types_mod 8 3).
Compute (types_mod 8 false).
Compute (types_mod 8 true).
Compute (types_mod true 4).

(*not*)

Definition types_not (x : Types) :=
match x with
| TypeNat x => match x with
               | 0 => TypeBool true
               | _ => TypeBool false
               end
| TypeBool x => match x with
               | true => TypeBool false
               | false => TypeBool true
               end
| _ => ErrorBool
end.

Compute(types_not true).
Compute(types_not false).
Compute(types_not 5).
Compute(types_not 0).

(* and *)

Definition types_and (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match x, y with
                          | _, 0 => TypeBool false
                          | 0, _ => TypeBool false
                          | _, _ => TypeBool true
                          end
| TypeBool x, TypeBool y => match x, y with
                            | _, false => TypeBool false
                            | false, _ => TypeBool false
                            | _, _ => TypeBool true
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, _ => TypeBool false
                           | _, false => TypeBool false
                           | _, _ => TypeBool true
                           end
| TypeBool x, TypeNat y => match x, y with
                           | false, _ => TypeBool false
                           | _, 0 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_and 3 5).
Compute (types_and true false).
Compute (types_and 0 true).
Compute (types_and true true).

(* or *)

Definition types_or (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => match x, y with
                          | 0, 0 => TypeBool false
                          | _, _ => TypeBool true
                          end
| TypeBool x, TypeBool y => match x, y with
                            | false, false => TypeBool false
                            | _, _ => TypeBool true
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, false => TypeBool false
                           | _, _ => TypeBool true
                           end
| TypeBool x, TypeNat y => match x, y with
                           | false, 0 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_or true 8).
Compute (types_or 0 false).
Compute (types_or 6 0).
Compute (types_or true false).

(* mai mic < *)

Definition types_less (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeBool (ltb x y)
| TypeBool x, TypeBool y => match x, y with
                            | false, true => TypeBool true
                            | _, _ => TypeBool false
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, true => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeBool x, TypeNat y => match x, y with
                           | false, 0 => TypeBool false
                           | true, 0 => TypeBool false
                           | true, 1 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_less 4 7).
Compute (types_less 4 3).
Compute (types_less true 7).
Compute (types_less 4 true).
Compute (types_less false true).
Compute (types_less true true).

(* mai mic egal <= *)

Definition types_lessequal (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeBool (Nat.leb x y)
| TypeBool x, TypeBool y => match x, y with
                            | false, _ => TypeBool true
                            | true, true => TypeBool true
                            | _, _ => TypeBool false
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, _ => TypeBool true
                           | 1, true => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeBool x, TypeNat y => match x, y with
                           | true, 0 => TypeBool false
                           | _, _ => TypeBool true
                           end
| _, _ => ErrorBool
end.

Compute (types_lessequal 4 7).
Compute (types_lessequal 4 3).
Compute (types_lessequal true 7).
Compute (types_lessequal 4 true).
Compute (types_lessequal false true).
Compute (types_lessequal true true).

(* mai mare > *)

Definition types_greater (x y : Types) := types_not (types_lessequal x y).

Compute (types_greater 6 4).
Compute (types_greater 4 6).

(* mai mare egal >= *)

Definition types_greaterequal (x y : Types) := types_not (types_less x y).

Compute (types_greaterequal 6 4).
Compute (types_greaterequal 4 4).

(* egal = *)

Definition types_equal (x y : Types) :=
match x, y with
| TypeNat x, TypeNat y => TypeBool (Nat.eqb x y)
| TypeBool x, TypeBool y => match x, y with
                            | false, false => TypeBool true
                            | true, true => TypeBool true
                            | _, _ => TypeBool false
                            end
| TypeNat x, TypeBool y => match x, y with
                           | 0, false => TypeBool true
                           | 1, true => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeBool x, TypeNat y => match x, y with
                           | true, 1 => TypeBool true
                           | false, 0 => TypeBool true
                           | _, _ => TypeBool false
                           end
| TypeString x, TypeString y => TypeBool (string_beq x y)
| _, _ => ErrorBool
end.

Compute (types_equal 5 5).
Compute (types_equal true true).
Compute (types_equal true false).
Compute (types_equal true 1).
Compute (types_equal true 5).

(* inegal !=*)

Definition types_notequal (x y : Types) := types_not (types_equal x y).

Compute (types_notequal true true).
Compute (types_notequal true false).
Compute (types_notequal true 1).
Compute (types_notequal true 5).

Definition isTrue (b: Bool) : bool :=
match b with
| TypeBool true => true
| TypeBool false => false
| ErrorBool => false
end.

Definition verify (e: Types) : bool :=
match e with
| Bools b => match b with
             | TypeBool b' => isTrue(b')
             | _ => false
             end
| _ => false
end.

Fixpoint Eval (exp : Exp) (env : Env) : Types :=
match exp with
| anum x => x
| avar x => env x
| str x => x
| aplus x y => types_plus (Eval x env) (Eval y env)
| aminus x y => types_minus (Eval x env) (Eval y env)
| amul x y => types_mul (Eval x env) (Eval y env)
| adiv x y => types_div (Eval x env) (Eval y env)
| amod x y => types_mod (Eval x env) (Eval y env)
| btrue => true
| bfalse => false
| not' x => types_not (Eval x env)
| and' x y => types_and (Eval x env) (Eval y env)
| or' x y => types_or (Eval x env) (Eval y env)
| less x y => types_less (Eval x env) (Eval y env)
| lessequal x y => types_lessequal (Eval x env) (Eval y env)
| greater x y => types_greater (Eval x env) (Eval y env)
| greaterequal x y => types_greaterequal (Eval x env) (Eval y env)
| equal x y => types_equal (Eval x env) (Eval y env)
| notequal x y => types_notequal (Eval x env) (Eval y env)
end.

Compute (Eval (equal (anum 9) (anum 1)) env1).

(* Functii pentru liste *)

(* lungimea unei liste *)

Fixpoint get_list_length {T : Type} (l : list T) :=
match l with
| nil => 0
| cons _ val l2 => 1 + get_list_length l2
end.

Compute get_list_length list1nat.
Compute get_list_length list2bool.

(* get element dintr-o lista *)

Fixpoint get_element_list_nat (l : list Nat) ( poz : nat ) :=
match l with
| nil => Error
| cons _ val l2 => if(Nat.eqb poz 0)
                   then val
                    else
                    get_element_list_nat l2 (poz-1)
end.

Fixpoint get_element_list_bool (l : list Bool) (poz : nat) :=
match l with
| nil => Error
| cons _ val l2 => if(Nat.eqb poz 0)
                   then val
                    else
                    get_element_list_bool l2 (poz-1)
end.

Fixpoint get_element_list_string (l : list String) (poz : nat) :=
match l with
| nil => Error
| cons _ val l2 => if(Nat.eqb poz 0)
                   then val
                    else
                    get_element_list_string l2 (poz-1)
end.

Fixpoint get_element_list_array (l : list Array) (poz : nat) :=
match l with
| nil => Error
| cons _ val l2 => if(Nat.eqb poz 0)
                   then val
                    else
                    get_element_list_array l2 (poz-1)
end.

Compute get_element_list_nat list1nat 1.
Compute get_element_list_bool list1bool 3.

(* set element intr-o lista *)

Fixpoint set_element_list_nat (l : list Nat) (poz : nat) (val : Nat) :=
match l with
| nil => if (Nat.eqb poz 0)
         then (cons _ val [])
         else nil
| cons _ v l2 => if ( Nat.eqb poz 0 )
                    then (cons _ val l2)
                    else cons _ v (set_element_list_nat l2 (poz-1) val)
end.

Compute set_element_list_nat {1,2,3,4} 4 5.

Fixpoint set_element_list_bool (l : list Bool) (poz : nat) (val : Bool) :=
match l with
| nil => if (Nat.eqb poz 0)
         then (cons _ val [])
         else nil
| cons _ v l2 => if ( Nat.eqb poz 0 )
                    then (cons _ val l2)
                    else cons _ v (set_element_list_bool l2 (poz-1) val)
end.

Fixpoint set_element_list_string (l : list String) (poz : nat) (val : String) :=
match l with
| nil => if (Nat.eqb poz 0)
         then (cons _ val [])
         else nil
| cons _ v l2 => if ( Nat.eqb poz 0 )
                    then (cons _ val l2)
                    else cons _ v (set_element_list_string l2 (poz-1) val)
end.

Fixpoint set_element_list_array (l : list Array) (poz : nat) (val : Array) :=
match l with
| nil => if (Nat.eqb poz 0)
         then (cons _ val [])
         else nil
| cons _ v l2 => if ( Nat.eqb poz 0 )
                    then (cons _ val l2)
                    else cons _ v (set_element_list_array l2 (poz-1) val)
end.

(* pop dintr-o lista*)

Fixpoint pop_List {T: Type} (l: list T) :=
match l with
| cons _ l' [] => []
| cons _ v l' => cons _ v (pop_List l')
| [] => []
end.

(* Functii pentru vectori *)

(* lungimea unui vector *)

Definition get_array_length (v : Array) :=
match v with
| NatArray l => get_list_length l
| BoolArray l => get_list_length l
| StringArray l => get_list_length l
| Matrix l => get_list_length l
end.

Compute get_array_length vector_nat.

(* get pentru vector*)

Definition get_element_array (v : Array)(poz : nat) :=
match v with
| NatArray l => get_element_list_nat l poz
| BoolArray l => get_element_list_bool l poz
| StringArray l => get_element_list_string l poz
| Matrix l => get_element_list_array l poz
end.

Compute get_element_list_nat list1nat 1.
Compute get_element_array vector_nat 1.
Compute get_element_array vector_bool 2.

(* set pentru vector*)

Definition set_element_array_nat (v : Array) (poz : nat) (val : Nat) :=
match v with
| NatArray l => NatArray( set_element_list_nat l poz val )
| _ => v
end.

Definition set_element_array_bool (v : Array) (poz : nat) (val : Bool) :=
match v with
| BoolArray l => BoolArray ( set_element_list_bool l poz val )
| _ => v
end.

Definition set_element_array_string (v : Array) (poz : nat) (val : String) :=
match v with
| StringArray l => StringArray ( set_element_list_string l poz val )
| _ => v
end.

Definition set_element_matrix (v : Array) (poz : nat) (val : Array) :=
match v with
| Matrix l => Matrix ( set_element_list_array l poz val )
| _ => v
end.

Definition vector_nat2 := set_element_array_nat vector_nat 2 10.
Compute vector_nat2.
Definition vector_bool2 := set_element_array_bool vector_bool 1 true.
Compute vector_bool2.

(* push intr-un vector *)

Definition pushToNat (v : Array) (val : Nat) :=
match v with
| NatArray l => NatArray(set_element_list_nat l (get_list_length l) val)
| _ => v
end.

Definition pushToBool (v : Array) (val : Bool) :=
match v with
| BoolArray l => BoolArray (set_element_list_bool l (get_list_length l) val)
| _ => v
end.

Definition pushToString (v : Array) (val : String) :=
match v with
| StringArray l => StringArray (set_element_list_string l (get_list_length l) val)
| _ => v
end.

Definition pushToMatrix (v : Array) (val : Array) :=
match v with
| Matrix l => Matrix (set_element_list_array l (get_list_length l) val)
| _ => v
end.

Compute vector_nat.
Compute vector_bool.
Compute pushToNat vector_nat 50.
Compute pushToBool vector_bool true.

(* pop dintr-un vector*)

Definition popArray (v : Array) :=
match v with
| NatArray l => NatArray (pop_List l)
| BoolArray l => BoolArray (pop_List l)
| StringArray l => StringArray (pop_List l)
| Matrix l => Matrix (pop_List l)
end.

Compute vector_nat.
Compute popArray vector_nat.

Notation "pop( V )" := (popArray V) (at level 79).
Notation "length( V )" := (get_array_length V) (at level 79).

Notation "V [ P ]" := (get_element_array V P)(at level 78).
Compute vector_nat.
Compute vector_nat[2].

(* Functii pentru switch*)

Definition get_pairStmt (P : pairs) : Stmt :=
match P with
| default:{ s }; => s
| case( _ ):{ s }; => s
end.

Definition checkPair (P : pairs ) (n : Types) : bool :=
match P with
| default:{ _ }; => true
| case( a ):{ _ }; => verify (types_equal a n)
end.

Fixpoint get_switch_case (n : Types) (l : list pairs) : Stmt :=
match n with
| TypeNat n' => match l with
              | nil => empty
              | cons _ x l2 => if (checkPair x n) then (get_pairStmt x) else (get_switch_case n l2)
              end
| _ => empty
end.

Definition switch1 := (
      natural "x" ;s; "x" :n= 5 ;s; boolean "y" ;s;
      switch( "x" ){
        case( 1 ):{ empty }; ;sw;
        case( 3 ):{ "x" :n= 100 }; ;sw;
        case( 5 ):{ "x" :n= 50 }; ;sw;
        case( 7 ):{  "y" :b= btrue}; ;sw;
        default:{ "x" :n= 0 };
     }end

).

Definition list_switch := ( { case( 1 ):{ empty }; ;sw;
                              case( 3 ):{ "x" :n= 100 }; ;sw;
                              case( 5 ):{ "x" :n= 50 }; ;sw;
                              case( 7 ):{  "y" :b= btrue}; ;sw;
                              default:{ "x" :n= 0 };
                              } ).
Compute get_switch_case 3 list_switch.

(* Functii pentru struct *)

(* get first dintr-o pereche de struct *)

Definition pair_get_first (p : pair_struct) :=
match p with
| pair first second => first
end.

(* get second dintr-o pereche de struct *)

Definition pair_get_second (p : pair_struct) :=
match p with
| pair first second => second
end.

(* get second dintr-o lista de perechi de struct *)
Fixpoint get_element_pairlist (l : list pair_struct) (f : string) :=
match l with
| nil => inexistent
| cons _ field l2 => if ( eqb_string f ( pair_get_first field ))
                     then pair_get_second field
                     else get_element_pairlist l2 f
end.

(* set second intr-o lista de perechi de struct pe baza first *)

Fixpoint set_element_pairlist (l : list pair_struct) (f : string) (val : types_allowed) :=
match l with
| nil => nil
| cons _ field l2 => if ( eqb_string f (pair_get_first field) )
                      then cons _ (pair (pair_get_first field) val) l2
                      else cons _ field (set_element_pairlist l2 f val)
end.

(* get pentru struct *)

Definition get_element_for_struct (str : Struct) (field : string) :=
match str with
| struct_cons list_pair => get_element_pairlist list_pair field
end.

(* set pentru struct *)

Definition set_element_for_struct (str : Struct) (field : string) (val : types_allowed) :=
match str with
| struct_cons list_pair => struct_cons (set_element_pairlist list_pair field val)
end.

Definition struct1 := struct_cons { ("Varsta" , 5 ) ;; ( "Rasa" , "Bichon" ) ;; ( "Culoare" , "Alb" ) } .

Compute get_element_for_struct struct1 "Varsta".
Compute set_element_for_struct struct1 "Varsta" 6.

Definition struct2 := set_element_for_struct struct1 "Rasa" "Bulldog".
Compute struct2.

Notation "'getS' N '[(' F ')]'" := (get_element_for_struct N F) (at level 79).

Compute struct1.
Compute getS struct1 [("Rasa")].

(* Functii pentru map*)

(* lungimea unui map *)

Definition get_map_length (m : MapTypes) :=
match m with
| natstring k v => get_list_length k
| stringnat k v => get_list_length k
| natnat k v => get_list_length k
| stringstring k v => get_list_length k
end.

Compute get_map_length map1.
Compute get_map_length map2.

(* gasirea pozitiei unei chei intr-o lista de numere Nat*)

Fixpoint find_position_nat (l : list Nat) (val : nat) :=
match l with
| nil => 1
| cons _ v l2 => if( Nat_beq val v )
                then 0
                else 1 + (find_position_nat l2 val)
end.

Compute list1nat.
Compute find_position_nat list1nat 90.

(* gasirea pozitiei unei chei intr-o lista de numere String*)

Fixpoint find_position_string (l : list String) (val : string) :=
match l with
| nil => 1
| cons _ v l2 =>  if isTrue ( types_equal val v )
                     then 0
                     else 1 + (find_position_string l2 val)

end.

Compute list1string.
Compute find_position_string list1string "ioana".

(* get pentru map pe baza unei chei *)

Definition get_map_value_nat (m : MapTypes) (k : nat) :=
match m with
| natnat l1 l2 => get_element_list_nat l2 (find_position_nat l1 k)
| natstring l1 l2 => get_element_list_string l2 (find_position_nat l1 k)
| _ => Error
end.

Compute map1.
Compute get_map_value_nat map1 14.
Compute get_map_value_nat map1 5.

Definition get_map_value_string (m : MapTypes) (k : string) :=
match m with
| stringnat l1 l2 => get_element_list_nat l2 (find_position_string l1 k)
| stringstring l1 l2 => get_element_list_string l2 (find_position_string l1 k)
| _ => Error
end.

Notation "'get_mapn' M :|: K " := (get_map_value_nat M K) (at level 79).
Notation "'get_maps' M :|: K " := (get_map_value_string M K) (at level 79).

Compute list1string.
Definition map3 := stringstring list1string list2string.
Compute map3.
Compute get_map_value_string map3 "ioana".

(* functie care verifica daca o cheie exista in map *)

Definition exists_nat (l : list Nat) (k : nat) :=
match l with
| nil => false
| _ => if ( Nat.leb (get_list_length l) (find_position_nat l k) )
            then false
            else true
end.

Compute list1nat.
Compute exists_nat list1nat 5.
Compute exists_nat list1nat 10.

Definition exists_string (l : list String) (k : string) :=
match l with
| nil => false
| _ => if ( Nat.leb (get_list_length l) (find_position_string l k) )
            then false
            else true
end.

Compute list1string.
Compute exists_string list1string "ioana".
Compute exists_string list1string "george".

Definition insert_element_nat (l : list Nat) (k : Nat) :=
match l with
| nil => set_element_list_nat l 0 k
| _ => set_element_list_nat l (get_list_length l) k
end.

Compute list1nat.
Compute insert_element_nat list1nat 10.
Definition list4nat := cons Nat 0 nil.
Compute list4nat.
Definition list5nat := pop_List list4nat.
Compute list5nat.
Compute insert_element_nat list5nat 5.

Definition insert_element_string (l : list String) (k : String) :=
match l with
| nil => set_element_list_string l 0 k
| _ => set_element_list_string l (get_list_length l) k
end.

Compute list1string.
Compute insert_element_string list1string "maria".

Definition insert_map_key_nat (m : MapTypes) (k : Nat) :=
match m with
| natnat l1 l2 => natnat (insert_element_nat l1 k) l2
| natstring l1 l2 => natstring (insert_element_nat l1 k) l2
| _ => m
end.

Definition insert_map_key_string (m : MapTypes) (k : String) :=
match m with
| stringstring l1 l2 => stringstring (insert_element_string l1 k) l2
| stringnat l1 l2 => stringnat (insert_element_string l1 k) l2
| _ => m
end.

Definition insert_map_value_nat (m : MapTypes) (k : Nat) :=
match m with
| natnat l1 l2 => natnat l1 (insert_element_nat l2 k)
| stringnat l1 l2 => stringnat l1 (insert_element_nat l2 k)
| _ => m
end.

Definition insert_map_value_string (m : MapTypes) (k : String) :=
match m with
| stringstring l1 l2 => stringstring l1 (insert_element_string l2 k)
| natstring l1 l2 => natstring l1 (insert_element_string l2 k)
| _ => m
end.

(* set pentru un map *)

Definition set_map_value_natnat (m : MapTypes) (k : nat) (v : Nat) :=
match m with
| natnat l1 l2 => if ( exists_nat l1 k )
                      then natnat l1 (set_element_list_nat l2 (find_position_nat l1 k) v)
                      else
                      insert_map_value_nat (insert_map_key_nat m k) v
| _ => m
end.

Definition set_map_value_natstring (m : MapTypes) (k : nat) (v : String) :=
match m with
| natstring l1 l2 => if ( exists_nat l1 k )
                      then natstring l1 (set_element_list_string l2 (find_position_nat l1 k) v)
                      else
                      insert_map_value_string (insert_map_key_nat m k) v
| _ => m
end.

Definition set_map_value_stringnat (m : MapTypes) (k : string) (v : Nat) :=
match m with
| stringnat l1 l2 => if ( exists_string l1 k )
                      then stringnat l1 (set_element_list_nat l2 (find_position_string l1 k) v)
                      else
                      insert_map_value_nat (insert_map_key_string m k) v
| _ => m
end.

Definition set_map_value_stringstring (m : MapTypes) (k : string) (v : String) :=
match m with
| stringstring l1 l2 => if ( exists_string l1 k )
                      then stringstring l1 (set_element_list_string l2 (find_position_string l1 k) v)
                      else
                      insert_map_value_string (insert_map_key_string m k) v
| _ => m
end.

Compute map1.
Compute set_map_value_natnat map1 3 10.
Compute set_map_value_natnat map1 6 10.

Notation "'get_mapn' M :|: K " := (get_map_value_nat M K) (at level 79).
Notation "'get_maps' M :|: K " := (get_map_value_string M K) (at level 79).

Compute map1.
Compute get_mapn map1 :|: 5.

Reserved Notation "E =[ S ]=> E'" (at level 60).

Reserved Notation "A =[ S ]=> N" (at level 60).
Inductive eval_exp : Exp -> Env -> Types -> Prop :=
| const : forall n sigma, anum n =[ sigma ]=> n
| var : forall v sigma, avar v =[ sigma ]=> (sigma v)
| add : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_plus i1 i2) ->
    (a1 +' a2) =[ sigma ]=> n
| minus : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_minus i1 i2) ->
    (a1 -' a2) =[ sigma ]=> n
| mul : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_mul i1 i2) ->
    (a1 *' a2) =[ sigma ]=> n
| div : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_div i1 i2) ->
    (a1 /' a2) =[ sigma ]=> n
| modul : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_mod i1 i2) ->
    (a1 %' a2) =[ sigma ]=> n
| b_true : forall sigma,
    btrue =[ sigma ]=> true
| b_false : forall sigma,
    bfalse =[ sigma ]=> false
| not : forall a i sigma n,
    a =[ sigma ]=> i ->
    n = (types_not i) ->
    (! a) =[ sigma ]=> n
| and : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_and i1 i2) ->
    (a1 &&' a2) =[ sigma ]=> n
| or : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_or i1 i2) ->
    (a1 ||' a2) =[ sigma ]=> n
| lessthan : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_less i1 i2) ->
    (a1 <' a2) =[ sigma ]=> n
| lessequalthan : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_lessequal i1 i2) ->
    (a1 <=' a2) =[ sigma ]=> n
| greaterthan : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_greater i1 i2) ->
    (a1 >' a2) =[ sigma ]=> n
| greaterthanequal : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_greaterequal i1 i2) ->
    (a1 >=' a2) =[ sigma ]=> n
| are_equal : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_equal i1 i2) ->
    (a1 ==' a2) =[ sigma ]=> n
| not_equal : forall a1 a2 i1 i2 sigma n,
    a1 =[ sigma ]=> i1 ->
    a2 =[ sigma ]=> i2 ->
    n = (types_notequal i1 i2) ->
    (a1 !=' a2) =[ sigma ]=> n
where "a =[ sigma ]=> n" := (eval_exp a sigma n).

Example true_operation : (1 +' 6 <=' 9 -' 2) =[ env1 ]=> true.
Proof.
 eapply lessequalthan.
 eapply add.
 eapply const.
 eapply const.
 simpl. reflexivity.
 eapply minus.
 eapply const.
 eapply const.
 simpl. reflexivity.
 reflexivity.
Qed.

Example errorNat_operation : (10 /' 0) =[ env1 ]=> ErrorNat.
Proof.
 eapply div.
 eapply const.
 eapply const.
 simpl. reflexivity.
Qed.

Example errorBool_operation : (7 %' 0 <' 7) =[ env1 ]=> ErrorBool.
Proof.
 eapply lessthan.
 eapply modul.
 eapply const.
 eapply const.
 simpl. reflexivity.
 eapply const.
 simpl. reflexivity.
Qed.

Definition env3 := update default "x" 15.

Example equal_operation : ("x" *' 4 ==' 60) =[ env3 ]=> true.
Proof.
 eapply are_equal.
 eapply mul.
 eapply var.
 eapply const.
 simpl. reflexivity.
 eapply const.
 simpl. reflexivity.
Qed.

Reserved Notation "S -{ Sigma }-> Sigma'" (at level 60).

Inductive eval_stmt : Stmt -> Env -> Env -> Prop :=
| declare_nat : forall a sigma sigma',
    sigma' = (update sigma a unassignedNat) ->
    (natural a) -{ sigma }-> sigma'
| declare_bool : forall a sigma sigma',
    sigma' = (update sigma a unassignedBool) ->
    (boolean a) -{ sigma }-> sigma'
| declare_string : forall a sigma sigma',
    sigma' = (update sigma a unassignedString) ->
    (char a) -{ sigma }-> sigma'

| assignment_nat : forall a (i : Nat) x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x i) ->
    (x :n= a) -{ sigma }-> sigma'
| assignment_bool : forall a (i : Bool) x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x i) ->
    (x :b= a) -{ sigma }-> sigma'
| assignment_string : forall a (i : String) x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x i) ->
    (x :s= a) -{ sigma }-> sigma'

| initialize_nat : forall a (i : Nat) x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x (Nats i)) ->
    (Natural x ::= a) -{ sigma }-> sigma'
| initialize_bool : forall a (i : Bool) x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x (Bools i)) ->
    (Boolean x ::= a) -{ sigma }-> sigma'
| initialize_string : forall a (i : String) x sigma sigma',
    a =[ sigma ]=> i ->
    sigma' = (update sigma x (Strings i)) ->
    (Char x ::= a) -{ sigma }-> sigma'

| e_seq : forall s1 s2 sigma sigma1 sigma2,
    s1 -{ sigma }-> sigma1 ->
    s2 -{ sigma1 }-> sigma2 ->
    (s1 ;s; s2) -{ sigma }-> sigma2

| e_iftrue : forall b s1 s2 sigma sigma',
    b =[ sigma ]=> true ->
    s1 -{ sigma }-> sigma' ->
    ifthenelse b s1 s2 -{ sigma }-> sigma'
| e_iffalse : forall b s1 s2 sigma sigma',
    b =[ sigma ]=> false ->
    s2 -{ sigma }-> sigma' ->
    ifthenelse b s1 s2 -{ sigma }-> sigma'
| e_ifthen_true : forall b s sigma sigma',
    b =[ sigma ]=> true ->
    s -{ sigma }-> sigma' ->
    ifthen b s -{ sigma }-> sigma'
| e_ifthen_false : forall b s sigma,
    b =[ sigma ]=> false ->
    ifthen b s -{ sigma }-> sigma

| e_whilefalse : forall b s sigma,
    b =[ sigma ]=> false ->
    while_loop b s -{ sigma }-> sigma
| e_whiletrue : forall b s sigma sigma1,
    b =[ sigma ]=> true ->
    (s ;s; while_loop b s) -{ sigma }-> sigma1 ->
    while_loop b s -{ sigma }-> sigma1

| e_fortrue: forall s1 x s2 s3 sigma sigma1 sigma2,
  s1 -{ sigma }-> sigma1 ->
  x =[ sigma1 ]=> true ->
  ( while_loop x ( s3 ;s; s2 ) ) -{ sigma1 }-> sigma2 ->
  for_loop s1 x s2 s3 -{ sigma }-> sigma2

| e_forfalse: forall s1 x s2 s3 sigma sigma1,
  s1 -{ sigma }-> sigma1 ->
  x =[ sigma ]=> false ->
  (for_loop s1 x s2 s3) -{ sigma }-> sigma1

| e_switch : forall a l sigma n v sigma',
    a =[ sigma ]=> n ->
    v = (get_switch_case n l) ->
    v -{ sigma }-> sigma' ->
    switch_case a l -{ sigma }-> sigma'
| declare_array_nat : forall a sigma sigma',
    sigma' = (update sigma a unassignedArray) ->
    ([Natural] a) -{ sigma }-> sigma'
| declare_array_bool : forall a sigma sigma',
    sigma' = (update sigma a unassignedArray) ->
    ([Boolean] a) -{ sigma }-> sigma'
| declare_array_string : forall a sigma sigma',
    sigma' = (update sigma a unassignedArray) ->
    ([String] a) -{ sigma }-> sigma'
| declare_matrix : forall a sigma sigma',
    sigma' = (update sigma a unassignedArray) ->
    ([[Matrix]] a) -{ sigma }-> sigma'

| initialize_array_nat : forall (a : Array) x sigma sigma',
    sigma' = (update sigma x a) ->
    ([Natural_I] x :in:= a) -{ sigma }-> sigma'
| initialize_array_bool : forall (a : Array) x sigma sigma',
    sigma' = (update sigma x a) ->
    ([Boolean_I] x :ib:= a) -{ sigma }-> sigma'
| initialize_array_string : forall (a : Array) x sigma sigma',
    sigma' = (update sigma x a) ->
    ([String_I] x :is:= a) -{ sigma }-> sigma'
| initialize_matrix : forall (a : Array) x sigma sigma',
    sigma' = (update sigma x a) ->
    ([[Matrix_I]] x :im:= a) -{ sigma }-> sigma'

| set_array_nat : forall a poz (val : Nat) sigma sigma',
    sigma' = match sigma a with
             | Arrays a' => update sigma a (set_element_array_nat a' poz val)
             | _ => sigma
             end ->
    (a [ poz ] :n= val) -{ sigma }-> sigma'

| set_array_bool : forall a poz (val : Bool) sigma sigma',
    sigma' = match sigma a with
             | Arrays a' => update sigma a (set_element_array_bool a' poz val)
             | _ => sigma
             end ->
    (a [ poz ] :b= val) -{ sigma }-> sigma'

| set_array_string : forall a poz (val : String) sigma sigma',
    sigma' = match sigma a with
             | Arrays a' => update sigma a (set_element_array_string a' poz val)
             | _ => sigma
             end ->
    (a [ poz ] :s= val) -{ sigma }-> sigma'

| set_matrix : forall a poz (val : Array) sigma sigma',
    sigma' = match sigma a with
             | Arrays a' => update sigma a (set_element_matrix a' poz val)
             | _ => sigma
             end ->
    (a [ poz ] :m= val) -{ sigma }-> sigma'

| push_nat : forall a (val : Nat) sigma sigma',
  sigma' = match sigma a with
             | Arrays a' => update sigma a (pushToNat a' val)
             | unassignedArray => update sigma a ( NatArray ( set_element_list_nat [] 0 val ) )
             | _ => sigma
             end ->
    (push_n( a ) val) -{ sigma }-> sigma'

| push_bool : forall a (val : Bool) sigma sigma',
  sigma' = match sigma a with
             | Arrays a' => update sigma a (pushToBool a' val)
             | unassignedArray => update sigma a ( BoolArray ( set_element_list_bool [] 0 val ) )
             | _ => sigma
             end ->
    (push_b( a ) val) -{ sigma }-> sigma'

| push_string : forall a (val : String) sigma sigma',
  sigma' = match sigma a with
             | Arrays a' => update sigma a (pushToString a' val)
             | unassignedArray => update sigma a ( StringArray ( set_element_list_string [] 0 val ) )
             | _ => sigma
             end ->
    (push_s( a ) val) -{ sigma }-> sigma'

| push_matrix : forall a (val : Array) sigma sigma',
  sigma' = match sigma a with
             | Arrays a' => update sigma a (pushToMatrix a' val)
             | unassignedArray => update sigma a ( Matrix ( set_element_list_array [] 0 val ) )
             | _ => sigma
             end ->
    (push_m( a ) val) -{ sigma }-> sigma'

| declare_struct : forall x (s : Struct) sigma sigma',
  sigma' = update sigma x (Structs s) ->
  (struct(x) s) -{ sigma }-> sigma'

| set_struct : forall s (val : types_allowed) field sigma sigma',
  sigma' = match sigma s with
           | Structs s' => update sigma s ( Structs (set_element_for_struct s' field val) )
           | _ => sigma
           end ->
   (setS s [( field )] := val ) -{ sigma }-> sigma'

| declare_map_nn : forall x m sigma sigma',
  sigma' = match m with
           | natnat m1 m2 => update sigma x m
           | _ => sigma
           end ->
  (Map x :nn= m) -{sigma}-> sigma'

| declare_map_ns : forall x m sigma sigma',
  sigma' = match m with
           | natstring m1 m2 => update sigma x m
           | _ => sigma
           end ->
  (Map x :ns= m) -{sigma}-> sigma'

| declare_map_sn : forall x m sigma sigma',
  sigma' = match m with
           | stringnat m1 m2 => update sigma x m
           | _ => sigma
           end ->
  (Map x :sn= m) -{ sigma}-> sigma'

| declare_map_ss : forall x m sigma sigma',
  sigma' = match m with
           | stringstring m1 m2 => update sigma x m
           | _ => sigma
           end ->
  (Map x :ss= m) -{ sigma }-> sigma'

| add_map_nn : forall m k v  sigma sigma',
  sigma' = match sigma m with
          | Maps m' => update sigma m (set_map_value_natnat m' k v)
          | _ => sigma
          end ->
  (add_nn m <- k :|: v ) -{ sigma }-> sigma'

| add_map_ns : forall m k v  sigma sigma',
  sigma' = match sigma m with
          | Maps m' => update sigma m (set_map_value_natstring m' k v)
          | _ => sigma
          end ->
  (add_ns m <- k :|: v ) -{ sigma }-> sigma'

| add_map_sn : forall m k v  sigma sigma',
  sigma' = match sigma m with
          | Maps m' => update sigma m (set_map_value_stringnat m' k v)
          | _ => sigma
          end ->
  (add_sn m <- k :|: v ) -{ sigma }-> sigma'

| add_map_ss : forall m k v  sigma sigma',
  sigma' = match sigma m with
          | Maps m' => update sigma m (set_map_value_stringstring m' k v)
          | _ => sigma
          end ->
  (add_ss m <- k :|: v ) -{ sigma }-> sigma'

where "s -{ sigma }-> sigma'" := (eval_stmt s sigma sigma').

Definition env4 := update default "x" 5.
Definition env5 := update env4 "contor" 0.
Definition env6 := update default "contor" 1.

Definition ex :=
While ("x" <' 6)
[ "contor" :n= ( "contor" +' 1 ) ;s;
  "x" :n= ( "x" +' 1 ) ]
EndW .

Example operation :  exists sigma0, ex -{ env5 }-> sigma0 /\ sigma0 "contor" = 1.
Proof.
  eexists. split. unfold ex.
 eapply e_whiletrue.
 eapply lessthan.
 eapply var.
 eapply const. simpl. reflexivity.
 repeat eapply e_seq.
 eapply assignment_nat. eapply add.
 eapply var. eapply const. simpl. reflexivity. reflexivity.
 eapply assignment_nat. eapply add. eapply var.
 eapply const. simpl. reflexivity. reflexivity.
-repeat eapply e_seq.
eapply e_whilefalse.
eapply lessthan. eapply var. eapply const. simpl. reflexivity.
-reflexivity.
Qed.

Definition env7 := update (update default "x" 5) "x" 50.
Example switch_operation :
      switch( "x" ){
        case( 1 ):{ empty }; ;sw;
        case( 3 ):{ "x" :n= 30 }; ;sw;
        case( 5 ):{ "x" :n= 50 }; ;sw;
        case( 7 ):{ "y" :b= bfalse}; ;sw;
        default:{ "x" :n= 0 };
     }end  -{ env4 }-> env7.

Proof.
-eapply e_switch.
 eapply var. simpl. reflexivity.
 eapply assignment_nat.
 eapply const.
 reflexivity.
Qed.

Definition program1 :=
switch( "x" ){
        case( 1 ):{ empty }; ;sw;
        case( 3 ):{ "x" :n= 30 }; ;sw;
        case( 5 ):{ "x" :n= 50 }; ;sw;
        case( 7 ):{ "y" :b= bfalse}; ;sw;
        default:{ "x" :n= 0 };
     }end
.

Example prog1: exists sigma0, program1 -{ env4 }-> sigma0 /\ sigma0 "x" = 50.
Proof.
  eexists. split. unfold program1.
  eapply e_switch.
  eapply var. simpl. reflexivity.
  eapply assignment_nat. eapply const.
  reflexivity. eauto.
Qed.

Definition program2 :=
natural "x" ;s; "x" :n= 2 ;s;
boolean "y" ;s; "y" :b= btrue ;s;
Natural "z" ::= 3 ;s;
"z" :n= ( "z" *' ( "x" +' "y" ) ).

Example prog2 : exists sigma0, program2 -{ default }-> sigma0 /\ sigma0 "z" = 9.
Proof.
  eexists. split. unfold program2.
  repeat eapply e_seq.
  eapply declare_nat. reflexivity.
  eapply assignment_nat. eapply const. reflexivity.
  eapply declare_bool. reflexivity.
  eapply assignment_bool. eapply b_true. reflexivity.
  eapply initialize_nat. eapply const. reflexivity.
  eapply assignment_nat. eapply mul. eapply var. eapply add. eapply var. eapply var.
  reflexivity. reflexivity. reflexivity. reflexivity.
Qed.

Definition program3 :=
Natural "sum" ::= 0 ;s; (
For (/ ( natural "i" ) ;s; ( "i" :n= 0 ) ;f; ( "i" <=' 2 ) ;f; ( "i" :n= "i" +' 1 ) \) {/
    If ( "i" %' 2 ==' 0 ) Then ( "sum" :n= "sum" +' 1 ) Else ( "sum" :n= "sum" +' 2 ) EndIte
    \}
    EndF ).

Example prog3 : exists sigma0, program3 -{ default }-> sigma0 /\ sigma0 "sum" = 4.
Proof.
 eexists. split. unfold program3.
 repeat eapply e_seq.
 eapply initialize_nat. eapply const. reflexivity.
 eapply e_fortrue.
 repeat eapply e_seq.
 eapply declare_nat. reflexivity.
 eapply assignment_nat. eapply const. reflexivity.
 eapply lessequalthan. eapply var. eapply const. simpl.
 repeat eapply e_seq.
 reflexivity.
 eapply e_whiletrue.
 eapply lessequalthan. eapply var. eapply const. reflexivity.
 repeat eapply e_seq.
 eapply e_iftrue. eapply are_equal. eapply modul. eapply var. eapply const. reflexivity. eapply const.
 simpl. reflexivity.
 eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
 eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
 eapply e_whiletrue.
 eapply lessequalthan. eapply var. eapply const. reflexivity.
 repeat eapply e_seq.
 eapply e_iffalse. eapply are_equal. eapply modul. eapply var. eapply const. reflexivity. eapply const.
 simpl. reflexivity.
 eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
 eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
 eapply e_whiletrue.
 eapply lessequalthan. eapply var. eapply const. reflexivity.
 repeat eapply e_seq.
 eapply e_iftrue. eapply are_equal. eapply modul. eapply var. eapply const. reflexivity. eapply const.
 simpl. reflexivity.
 eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
 eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
 eapply e_whilefalse.
 eapply lessequalthan. eapply var. eapply const. reflexivity. simpl. reflexivity.
Qed.

Definition program4 :=
[Natural] "v" ;s;
push_n( "v" ) 4 ;s;
push_n( "v" ) 3 ;s;
push_n( "v" ) 2 ;s;
push_n( "v" ) 1 .

Example prog4 : exists sigma0, program4 -{ default }-> sigma0 /\ sigma0 "v" = ( [Natural] = {4, 3, 2, 1} ).
Proof.
 eexists. split. unfold program4.
 repeat eapply e_seq.
 eapply declare_array_nat. reflexivity.
 eapply push_nat. reflexivity.
 eapply push_nat. reflexivity.
 eapply push_nat. reflexivity.
 eapply push_nat. reflexivity.
 simpl. reflexivity.
Qed.

Definition struct3 := struct_cons { ("Varsta" , 5 ) ;; ( "Nume" , "Ioana" ) ;; ( "Zodie" , "Berbec" ) } .

Definition program5 :=
struct( "x" ) struct3 ;s;
setS "x" [( "Nume" )] := "Pelin".

Example prog5 : exists sigma0, program5 -{ default }-> sigma0 /\ sigma0 "x" = Structs ( struct_cons { ("Varsta" , 5 ) ;; ( "Nume" , "Pelin" ) ;; ( "Zodie" , "Berbec" ) } ).
Proof.
 eexists. split. unfold program5.
 repeat eapply e_seq.
 eapply declare_struct. reflexivity.
 eapply set_struct. reflexivity. simpl. reflexivity.
Qed.

Compute map1.

Definition program6 :=
Map "map" :nn= natnat {1, 3, 5, 7, 9} {1, 3, 5, 7, 9} ;s;
add_nn "map" <- 5 :|: 10 ;s;
add_nn "map" <- 7 :|: 11.

Example prog6 : exists sigma0, program6 -{ default }-> sigma0 /\ sigma0 "map" = natnat {1, 3, 5, 7, 9} {1, 3, 10, 11, 9}.
Proof.
 eexists. split. unfold program6.
 repeat eapply e_seq.
 eapply declare_map_nn. reflexivity.
 eapply add_map_nn. reflexivity.
 eapply add_map_nn. reflexivity. reflexivity.
 Qed.

Definition program7 :=
Natural "sum" ::= 0 ;s; natural "d" ;s; "d" :n= 1 ;s;

While ( "d" *' "d" <=' 8 )
    [  If ( (8 %' "d") ==' 0 )
      Then
          ( ( "sum" :n= "sum" +' "d" )  ;s; ( "sum" :n= "sum" +' ( 8 /' "d" ) ) )
      Else
       ( "sum" :n= "sum" +' 0 )
      EndIte  ;s;
      "d" :n= "d" +' 1
     ]
EndW.

Example prog7 : exists sigma0, program7 -{ default }-> sigma0 /\ sigma0 "sum" = 15.
Proof.
  eexists. split. unfold program7.
  repeat eapply e_seq.
  eapply initialize_nat. eapply const. reflexivity.
  eapply declare_nat. reflexivity.
  eapply assignment_nat. eapply const. reflexivity.
  eapply e_whiletrue. eapply lessequalthan. eapply mul. eapply var. eapply var. reflexivity. eapply const. reflexivity.
  repeat eapply e_seq.
  eapply e_iftrue. eapply are_equal. eapply modul. eapply const. eapply var. reflexivity.
  eapply const. reflexivity.
  repeat eapply e_seq.
  eapply assignment_nat. eapply add. eapply var. eapply var. reflexivity. reflexivity.
  eapply assignment_nat. eapply add. eapply var. eapply div. eapply const. eapply var. reflexivity. reflexivity. reflexivity.
  eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
  eapply e_whiletrue. eapply lessequalthan. eapply mul. eapply var. eapply var. reflexivity. eapply const. reflexivity.
  repeat eapply e_seq.
  eapply e_iftrue. eapply are_equal. eapply modul. eapply const. eapply var. reflexivity.
  eapply const. reflexivity.
  repeat eapply e_seq.
  eapply assignment_nat. eapply add. eapply var. eapply var. reflexivity. reflexivity.
  eapply assignment_nat. eapply add. eapply var. eapply div. eapply const. eapply var. reflexivity. reflexivity. reflexivity.
  eapply assignment_nat. eapply add. eapply var. eapply const. reflexivity. reflexivity.
  eapply e_whilefalse. eapply lessequalthan. eapply mul. eapply var. eapply var. reflexivity. eapply const. reflexivity. reflexivity.
Qed.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import finset.
Require Import paths.
Require Import connect.

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

(* Minimal handling of signed integers:                                 *)
(*    - the additive group.                                             *)
(*    - comparison                                                      *)
(*    - increment/decrement                                             *)
(*    - halving/parity                                                  *)
(*    - multiplication (mostly for the construction of the reals)       *)
(*    - summations over finite domains, and over quotients in such      *)
(*      domains                                                         *)

Inductive znat : Set :=
  | Zpos (n : nat)
  | Zneg (m : nat).

Delimit Scope znat_scope with Z.
Bind Scope znat_scope with znat.
Open Local Scope znat_scope.

Coercion Zpos: nat >-> znat.

Fixpoint subnz (m n : nat) {struct m} : znat :=
  match m, n with
  | O, _ => Zneg n
  | S m', O => m'
  | S m', S n' => subnz m' n'
  end.

Definition addz z1 z2 :=
  match z1, z2 with
  | Zpos n1, Zpos n2 => Zpos (n1 + n2)
  | Zpos n1, Zneg n2 => subnz n1 n2
  | Zneg n1, Zneg n2 => Zneg (S (n1 + n2))
  | Zneg n1, Zpos n2 => subnz n2 n1
  end.

Notation "z1 + z2" := (addz z1 z2) : znat_scope.

Lemma zpos_addn : forall n1 n2, Zpos (n1 + n2) = n1 + n2.
Proof. done. Qed.

Lemma add0z : forall z, 0 + z = z. Proof. by case. Qed.

Lemma addzC : forall z1 z2, z1 + z2 = z2 + z1.
Proof. by move=> [n|n] [m|m]; rewrite /= 1?addnC. Qed.

Lemma addz0 : forall z, z + (Zpos 0) = z.
Proof. by move=> *; rewrite addzC add0z. Qed.

Lemma addzA : forall z1 z2 z3, z1 + (z2 + z3) = z1 + z2 + z3.
Proof.
have Hsub: forall m n p, subnz (m + n) p = (subnz m p) + n.
  by move=> m n; elim: m => [|m Hrec] [|p] /=.
have Hsub': forall m n p, subnz m (S (n + p)) = (subnz m n) + Zneg p.
  by move=> m n p; elim: m n => [|m Hrec] [|n]; try exact (Hrec n).
move=> [n|n] [m|m] [p|p]; rewrite /= ?addnI ?addnS ?addnA //.
- by rewrite addnC Hsub addzC.
- by rewrite -Hsub addnC Hsub addzC.
- by rewrite -Hsub' addnC Hsub' addzC.
by rewrite addnC Hsub' addzC.
Qed.

Lemma addzCA : forall z1 z2 z3, z1 + (z2 + z3) = z2 + (z1 + z3).
Proof. by move=> z1 *; rewrite !addzA (addzC z1). Qed.

Definition oppz z := match z with
 | Zpos (S n') => Zneg n'
 | Zneg n => Zpos (S n)
 | _ => z
end.
Notation "- z" := (oppz z) : znat_scope.
Notation "z1 - z2" := (addz z1 (oppz z2)) : znat_scope.

Lemma oppzS : forall n, - S n = Zneg n. Proof. done. Qed.

Lemma oppz_opp : forall z, - - z = z.
Proof. by move=> [[|n]|n]. Qed.

Lemma subzz : forall z, z - z = Zpos 0.
Proof. by move=> [[|n]|n]; try elim: n => /=. Qed.

Lemma addz_opp_inv : forall z, monic (addz (- z)) (addz z).
Proof. by move=> z1 z2; rewrite addzA subzz add0z. Qed.

Lemma addz_inv : forall z, monic (addz z) (addz (- z)).
Proof. move=> z; rewrite -{1}[z]oppz_opp; apply: addz_opp_inv. Qed.

Lemma addz_inj : forall z, injective (addz z).
Proof. move=> z; exact: (monic_inj (addz_inv z)). Qed.

Lemma oppz_add : forall z1 z2, - (z1 + z2) = - z1 - z2.
Proof.
move=> z1 z2; apply (@addz_inj (z1 + z2)).
by rewrite subzz -addzA (addzCA z2) addzA !subzz.
Qed.

Lemma subz0 : forall z, z - 0 = z. Proof. exact: addz0. Qed.

Lemma sub0z : forall z, 0 - z = - z. Proof. move=> z; exact: add0z. Qed.

Lemma zpos_subn : forall n1 n2,
   Zpos (n1 - n2)%dnat = if (n2 <= n1)%dnat then (n1 - n2)%Z else 0.
Proof.
elim=> [|n1 Hrec] [|n2] //=; first by rewrite addn0.
by rewrite subSS Hrec ltnS; case: n2 => //; rewrite subz0.
Qed.

Lemma addz_subA : forall z1 z2 z3, z1 + (z2 - z3) = z1 + z2 - z3.
Proof. move=> *; exact: addzA. Qed.

Lemma addz_subCA : forall z1 z2 z3, z1 + (z2 - z3) = z2 + (z1 - z3).
Proof. by move=> *; exact: addzCA. Qed.

Lemma addz_sub : forall z1 z2, z1 + (z2 - z1) = z2.
Proof. by move=> *; rewrite addz_subCA subzz addz0. Qed.

Lemma addz_sub2CA : forall z1 z2 z3 z4, z1 - z2 + (z3 - z4) = z1 - z4 + (z3 - z2).
Proof. by move=> z1 z2 z3 z4; rewrite -!addzA -!(addzCA z3) (addzC (-z2)). Qed.

Lemma addz_sub2 : forall z2 z1 z3, z1 - z2 + (z2 - z3) = z1 - z3.
Proof. by move=> *; rewrite addz_sub2CA subzz addz0. Qed.

Lemma subz_add : forall z1 z2, z1 + z2 - z1 = z2.
Proof. by move=> *; rewrite -addz_subA addz_sub. Qed.

Lemma subz_sub : forall z2 z1 z3, z1 - z2 - z3 = z1 - (z2 + z3).
Proof. by move=> *; rewrite oppz_add addzA. Qed.

Lemma subz_add2l : forall z1 z2 z3, z1 + z2 - (z1 + z3) = z2 - z3.
Proof.  by move=> *; rewrite -subz_sub subz_add. Qed.

Lemma subz_add2r : forall z1 z2 z3, (z1 + z2) - (z3 + z2) = z1 - z3.
Proof. by move=> z1 z2 z3; rewrite -!(addzC z2) subz_add2l. Qed.

Lemma oppz_sub : forall z1 z2, - (z1 - z2) = z2 - z1.
Proof. by move=> *; rewrite oppz_add oppz_opp addzC. Qed.

Definition incz z := match z with
 | Zpos n => Zpos (S n)
 | Zneg O => Zpos 0
 | Zneg (S n) => Zneg n
 end.

Definition decz z := match z with
 | Zneg n => Zneg (S n)
 | Zpos O => Zneg 0
 | Zpos (S n) => Zpos n
 end.

Lemma incz_def : forall z, incz z = z + 1.
Proof. by move=> z; rewrite addzC; case: z => [n|[|n]]. Qed.

Lemma decz_def : forall z, decz z = z - 1.
Proof. by move=> z; rewrite addzC; case: z => [[|n]|n]. Qed.

Lemma incz_dec : forall x, incz (decz x) = x.
Proof. by case=> [[|n]|m]. Qed.

Lemma decz_inc : forall x, decz (incz x) = x.
Proof. by case=> [n|[|m]]. Qed.

Definition posz z := if z is Zpos (S _) then true else false.

Lemma posz_add : forall z1 z2, posz (z1 + z2) -> posz z1 \/ posz z2.
Proof. by move=> [[|n]|n] [[|m]|m]; auto. Qed.

Lemma posz_cover : forall z, or3 (posz z) (z = 0) (posz (- z)).
Proof. by move=> [[|n]|n]; [ constructor 2 | constructor 1 | constructor 3 ]. Qed.

Definition leqz z1 z2 := negb (posz (z1 - z2)).

Notation "z1 '<=' z2" := (leqz z1 z2) : znat_scope.

Lemma leqzI : forall z1 z2, negb (posz (z1 - z2)) = (z1 <= z2).
Proof. done. Qed.

Lemma leqzz : forall z, z <= z.
Proof. by move=> *; rewrite /leqz subzz. Qed.

Lemma leqz_trans : forall z2 z1 z3, z1 <= z2 -> z2 <= z3 -> z1 <= z3.
Proof.
move=> z2 z1 z3 Hz12 Hz23; rewrite /leqz -(addz_sub2 z2).
by apply/idP; case/posz_add; apply: negP.
Qed.

Lemma leqz_add2l : forall z1 z2 z3, (z1 + z2 <= z1 + z3) = (z2 <= z3).
Proof. by move=> *; rewrite /leqz subz_add2l. Qed.

Lemma leqz_add2r : forall z1 z2 z3, (z2 + z1 <= z3 + z1) = (z2 <= z3).
Proof. by move=> *; rewrite /leqz subz_add2r. Qed.

Lemma leqz_add2 : forall z1 z2 z3 z4,
   z1 <= z2 -> z3 <= z4 -> z1 + z3 <= z2 + z4.
Proof.
move=> z1 z2 z3 z4 Hz12 Hz34.
by apply (@leqz_trans (z1 + z4)); [rewrite leqz_add2l | rewrite leqz_add2r].
Qed.

Lemma leqz_opp2 : forall z1 z2, (- z1 <= - z2) = (z2 <= z1).
Proof. by move=> *; rewrite {1}/leqz oppz_opp addzC. Qed.

Lemma leqz_nat : forall m n : nat, (m <= n) = (m <= n)%dnat.
Proof.
elim=> [|m Hrec] [|n] //; rewrite ltnS -Hrec.
by case n; rewrite /leqz //= addn0.
Qed.

Lemma leq0z : forall z, (0 <= z) = negb (posz (- z)).
Proof. by move=> [[|n]|n]. Qed.

Lemma leq1z : forall z, (1 <= z) = posz z.
Proof. by move=> [[|[|n]]|n]. Qed.

Definition eqz z1 z2 := if z1 - z2 is Zpos 0 then true else false.

Lemma eqzP : reflect_eq eqz.
Proof.
move=> z1 z2; apply: introP => [Hz12|Hz12 Dz1].
  rewrite -{1}[z2]addz0; apply (monic_move (addz_opp_inv z2)).
  by move: Hz12; rewrite addzC /eqz; case: (z1 - z2) => [[|n]|n].
by rewrite Dz1 /eqz subzz in Hz12.
Qed.

Canonical Structure znatData := DataSet eqzP.

Lemma eqz_leq : forall z1 z2 : znat, (z1 =d z2) = (z1 <= z2) && (z2 <= z1).
Proof.
move=> z1 z2; apply/idP/idP;
 first by move/eqP=> Dz1; rewrite Dz1 leqzz.
move/andP=> [Hz12 Hz21]; rewrite /leqz -oppz_sub /eqd /= /eqz in Hz21 Hz12 |- *.
by case: (posz_cover (z1 - z2)) Hz21 Hz12 => ->.
Qed.

Lemma leqz_inc : forall z1 z2, (z1 <= z2) = (z1 =d z2) || (incz z1 <= z2).
Proof.
move=> z1 z2; rewrite /leqz incz_def -addzA addzCA /eqd /= /eqz.
by case: (z1 - z2); case.
Qed.

Lemma leqz_dec : forall z1 z2, (z1 <= z2) = (z1 =d z2) || (z1 <= decz z2).
Proof.
move=> z1 z2; rewrite /leqz decz_def oppz_sub addzCA /eqd /= /eqz.
by case: (z1 - z2); case.
Qed.

Lemma leqz_inc2 : forall x y, (incz x <= incz y) = (x <= y).
Proof. by move=> *; rewrite !incz_def leqz_add2r. Qed.

Lemma leqz_dec2 : forall x y, (decz x <= decz y) = (x <= y).
Proof. by move=> *; rewrite !decz_def leqz_add2r. Qed.

Lemma leqz_dec_inc : forall x y, (decz x <= y) = (x <= incz y).
Proof. by move=> *; rewrite -leqz_inc2 incz_dec. Qed.

Lemma leqz_inc_dec : forall x y, (incz x <= y) = (x <= decz y).
Proof. by move=> *; rewrite -leqz_dec2 decz_inc. Qed.

Lemma leq_z_incz : forall x, x <= incz x.
Proof. by move=> *; rewrite leqz_inc leqzz orbT. Qed.

Lemma leq_decz_z : forall x, decz x <= x.
Proof. by move=> *; rewrite leqz_dec leqzz orbT. Qed.

Lemma leq_decz_incz : forall x, decz x <= incz x.
Proof. by move=> *; rewrite leqz_dec decz_inc leq_decz_z orbT. Qed.

Lemma negb_leqz : forall x y, negb (x <= y) = (incz y <= x).
Proof.
move=> x y; rewrite {2}/leqz -oppz_sub incz_def -subz_sub /leqz.
by case: (x - y) => [[|[|n]]|m].
Qed.

(* Parity & halving.                                 *)

Definition oddz z := match z with Zpos n => odd n | Zneg m => negb (odd m) end.

Lemma oddz_add : forall z1 z2, oddz (z1 + z2) = oddz z1 +b oddz z2.
Proof.
have Hsnz: forall m n, oddz (subnz m n) = negb (odd m +b odd n).
  elim=> //= [m Hrec] [|n] /=; first by rewrite addbF negb_elim.
  rewrite Hrec -!addbT; congr addb; rewrite -!addbA; congr addb.
  by rewrite addbC -addbA addbC.
move=> [m1|n1] [m2|n2] //=; rewrite ?odd_addn ?Hsnz //= -!addbT -!addbA //.
  by rewrite addbC -addbA.
by congr addb; rewrite addbA addbC.
Qed.

Lemma oddz_double : forall z, oddz (z + z) = false.
Proof. by move=> *; rewrite oddz_add addbb. Qed.

Definition halfz z := match z with
  | Zpos n => Zpos (half n)
  | Zneg m => Zneg (half m)
  end.

Lemma oddz_bit : forall b : bool, oddz b = b.
Proof. by case. Qed.

Lemma halfz_double : forall z, halfz (z + z) = z.
Proof. by case=> *; rewrite /= -double_addnn ?half_double ?uphalf_double. Qed.

Lemma halfz_bit : forall b : bool, halfz b = 0.
Proof. by case. Qed.

Lemma odd_double_halfz : forall z, oddz z + (halfz z + halfz z) = z.
Proof.
case=> [n|m]; first by rewrite /= -double_addnn odd_double_half.
rewrite {1}[addz]lock /= -lock -double_addnn -add1n.
by rewrite -(addn_negb (odd m)) -addnA odd_double_half; case (odd m).
Qed.

Lemma halfz_add_double : forall z1 z2, halfz (z1 + (z2 + z2)) = halfz z1 + z2.
Proof.
move=> z1 z2; rewrite -{1}[z1]odd_double_halfz -!addzA -(addzCA z2).
rewrite (addzA _ z2); case: (oddz z1) (halfz z1 + z2) => [|] [m|n] //=;
 by rewrite ?add0n -double_addnn ?half_double ?uphalf_double.
Qed.

Lemma leqz_halfr : forall x y, (x <= halfz y) = (x + x <= y).
Proof.
move=> x y; rewrite -{2}[y]odd_double_halfz; move: {y}(oddz y) (halfz y) => b y.
rewrite /leqz !oppz_add addzCA -addzA (addzCA _ (-y)) (addzA x).
by case: (x - y) b => [[|n]|[|m]] [|] //=; rewrite addnS.
Qed.

Lemma leqz_halfl : forall x y, (halfz x <= y) = (x <= incz (y + y)).
Proof.
move=> x y; rewrite -(leqz_inc2 x) -negb_leqz !incz_def addzC -!addzA addzCA.
by rewrite addzA -incz_def -leqz_halfr negb_leqz leqz_inc2.
Qed.

(* Multiplication.                                           *)

Definition mulz z1 z2 :=
  match z1 with
  | Zpos O => z1
  | Zpos (S n) => iter n (addz z2) z2
  | Zneg n => - (iter n (addz z2) z2)
  end.

Notation "z1 * z2" := (mulz z1 z2) : znat_scope.

Lemma mulz0 : forall z, z * 0 = 0.
Proof. by move=> [[|n]|n] //=; elim: n => // [n Hrec]; rewrite -iter_f. Qed.

Lemma mul0z : forall z, 0 * z = 0. Proof. done. Qed.

Lemma mulz_oppl : forall z1 z2, - z1 * z2 = - (z1 * z2).
Proof. by move=> [[|n]|n] //= z2; rewrite oppz_opp. Qed.

Lemma oppz_cases : forall P : znat -> Type,
 (forall z, P z -> P (- z)) -> (forall n : nat, P n) -> forall z, P z.
Proof.
move=> P Hopp Hpos z; rewrite -(oppz_opp z).
case: z => [n|n] //; auto; apply Hopp; apply: Hpos.
Qed.

Lemma mulz_oppr : forall z1 z2, z1 * (- z2) = - (z1 * z2).
Proof.
elim/oppz_cases; first by move=> m1 Hrec m2; rewrite !mulz_oppl Hrec.
by move=> [[|n]|n] //= z2; elim: n => [|n Hrec] //=; rewrite Hrec oppz_add.
Qed.

Lemma mulz_nat : forall n1 n2 : nat, n1 * n2 = (n1 * n2)%dnat.
Proof.
by move=> [|n1] n2 //=; elim: n1 => [|n1 Hrec] /=; rewrite ?addn0 ?Hrec.
Qed.

Lemma mulzC : forall z1 z2, z1 * z2 = z2 * z1.
Proof.
elim/oppz_cases=> [z1 Hz1|n1] z2; first by rewrite mulz_oppl mulz_oppr Hz1.
elim/oppz_cases: z2 => [z2 Hz2|n2]; first by rewrite mulz_oppl mulz_oppr Hz2.
by rewrite !mulz_nat mulnC.
Qed.

Lemma mulzA : forall z1 z2 z3, z1 * (z2 * z3) = z1 * z2 * z3.
Proof.
move=> z1 z2 z3; elim/oppz_cases: z1 => [z1 Hz1|n1].
  by rewrite !mulz_oppl Hz1.
elim/oppz_cases: z2 => [z2 Hz2|n2].
  by rewrite mulz_oppr !mulz_oppl mulz_oppr Hz2.
elim/oppz_cases: z3 => [z3 Hz3|n3]; first by rewrite !mulz_oppr Hz3.
by rewrite !mulz_nat mulnA.
Qed.

Lemma mulzCA : forall z1 z2 z3, z1 * (z2 * z3) = z2 * (z1 * z3).
Proof. by move=> z1 z2 z3; rewrite !mulzA (mulzC z1). Qed.

Lemma mul1z : forall z, 1 * z = z. Proof. done. Qed.
Lemma mulz1 : forall z, z * 1 = z. Proof. by move=> *; rewrite mulzC. Qed.

Lemma mulz_addr : forall z z1 z2, z * (z1 + z2) = (z * z1) + (z * z2).
Proof.
move=> z z1 z2; elim/oppz_cases: z => [z Hz|n].
  by rewrite !mulz_oppl -oppz_add Hz.
case: n => //=; elim=> [|n Hrec] //=.
by rewrite Hrec -!addzA; congr addz; rewrite addzCA.
Qed.

Lemma posz_mull : forall z z1, posz z -> posz (z * z1) = posz z1.
Proof.
case=> [[|n]|m] // [n1|m1] _; first by rewrite mulzC mulz_nat; case n1.
by rewrite -oppzS mulz_oppr mulz_nat.
Qed.

Lemma leqz_pmul2l : forall z z1 z2, posz z -> (z * z1 <= z * z2) = (z1 <= z2).
Proof.
move=> z z1 z2 Hz; congr negb; rewrite -mulz_oppr -mulz_addr; exact: posz_mull.
Qed.

(* A small theory of summations over finite subsets. *)

Section ZnatSums.

Variable d : finSet.

Definition sumz f a := foldr (fun x => addz (f x)) (0) (filter a (enum d)).

Lemma sumz0 : forall f, sumz f set0 = 0.
Proof. by move=> *; rewrite /sumz filter_set0. Qed.

Lemma eq_sumz_r : forall a b : set d, a =1 b -> forall f, sumz f a = sumz f b.
Proof. by move=> a b Eab f; rewrite /sumz (eq_filter Eab). Qed.

Lemma eq_sumz_l : forall f g (a : set d),
  (forall x, a x -> f x = g x) -> sumz f a = sumz g a.
Proof.
move=> f g a Efg; rewrite /sumz; elim: (enum d) => //= [x s Hrec].
by case Hx: (a x) => //=; rewrite Hrec Efg.
Qed.

Lemma eq_sumz : forall f g, f =1 g -> sumz f =1 sumz g.
Proof. move=> f g Efg a; apply: eq_sumz_l => x _; exact: Efg. Qed.

Lemma sumz_sub : forall f g a, sumz (fun x => f x - g x) a = sumz f a - sumz g a.
Proof.
move=> f g a; rewrite /sumz; elim: (filter a (enum d)) => //= x p ->.
by rewrite -subz_sub -!addzA (addzCA (- g x)).
Qed.

Definition zconst n (_ : d) := Zpos n.

Lemma zconstI : forall n, (fun _ => Zpos n) = zconst n.
Proof. done. Qed.

Lemma sumz_const : forall n a, sumz (zconst n) a = (n * card a)%dnat.
Proof.
move=> n a; rewrite /sumz /card count_filter mulnC.
by elim: {a}(filter a (enum d)) => [|x p Hrec] //=; rewrite Hrec.
Qed.

Lemma sumz_opp : forall f a, sumz (fun x => oppz (f x)) a = oppz (sumz f a).
Proof.
move=> f a; apply: etrans (etrans (sumz_sub (zconst 0) f a) _).
  by apply: eq_sumz => x; rewrite sub0z.
by rewrite sumz_const sub0z.
Qed.

Lemma sumz_add : forall f g a, sumz (fun x => f x + g x) a = sumz f a + sumz g a.
Proof.
move=> f g a; apply: etrans (etrans (sumz_sub f (fun x => - g x) a) _).
  by apply: eq_sumz => x; rewrite oppz_opp.
by rewrite sumz_opp oppz_opp.
Qed.

Lemma sumz_setID : forall b f a, sumz f a = sumz f (setI a b) + sumz f (setD a b).
Proof.
move=> b f a; rewrite /sumz; elim: (enum d) => [|x p Hrec] //=.
rewrite {1}/setD andbC {1}/setI /id; case (a x); rewrite //= Hrec.
by case (b x); rewrite /= -?addzA -?(addzCA (f x)).
Qed.

Lemma sumz_set1 : forall f x, sumz f (set1 x) = f x.
Proof.
move=> f x; move: (count_set1_enum x) (filter_enum (eqd x) x).
rewrite /sumz count_filter; case: (filter _ _) => [|y [|z p]] // _.
by rewrite /= set11 /setU1 orbF addz0; move/eqP=> ->.
Qed.

Lemma sumz_roots : forall e, connect_sym e -> forall f,
  sumz (fun x => sumz f (connect e x)) (roots e) = sumz f d.
Proof.
move=> e He f; set a := @setA d; rewrite (sumz_setID a) addzC.
rewrite -(@eq_sumz_r set0) // sumz0 add0z.
have: closed e a by done.
elim: {a}(S (card a)) {-2}a (ltnSn (card a)) => [|n Hrec] a //.
case: (pickP a) => [x Hx|Ha0] Hn Ha.
  rewrite (sumz_setID (set1 (root e x))) (sumz_setID (connect e x) f a).
  congr addz.
    apply: etrans (etrans (eq_sumz_r _ _) (sumz_set1 _ (root e x))) _.
    move=> y; rewrite /setI andbC; case: (root e x =P y) => // <-.
      by rewrite (roots_root He) /= -(closed_connect Ha (connect_root e x)).
    apply: eq_sumz_r => y; rewrite -(same_connect He (connect_root e x)).
    rewrite /setI andbC; case Hxy: (connect e x y); last done.
    by rewrite -(closed_connect Ha Hxy).
  apply: etrans (eq_sumz_r _ _) (Hrec _ _ _) => [y||y z Hyz].
  - rewrite /setD /setI; case Hy: (roots e y); rewrite /= ?andbF //.
    by rewrite -{1}(eqP Hy) (sameP eqP (rootPx He x y)).
  - rewrite ltnS -(cardIC (connect e x)) in Hn.
    apply: (leq_trans _ Hn); rewrite -add1n; apply leq_add2.
      by rewrite ltnNge leqn0; apply/set0Pn; exists x; rewrite /setI Hx connect0.
    by apply: subset_leq_card; apply/subsetP => y; rewrite /setD andbC.
  by rewrite /setD (Ha _ _ Hyz) !(He x) (same_connect He (connect1 Hyz)).
rewrite (eq_sumz_r Ha0) -(@eq_sumz_r set0) ?sumz0 //.
by move=> y; rewrite /setI Ha0 andbF.
Qed.

Lemma posz_sum : forall f a, posz (sumz f a) -> exists2 x, a x & posz (f x).
Proof.
move=> f a; rewrite /sumz; elim: (enum d) => [|x p Hrec] //=.
by case Hx: (a x) => [] //=; case/posz_add; first by exists x.
Qed.

Lemma sumz_perm : forall h, injective h -> forall a, fclosed h a ->
  forall f, sumz (fun x => f (h x)) a = sumz f a.
Proof.
move=> h Hh a Ha f; set ea := filter a (enum d).
have Ea: a =1 maps h ea.
  move=> x; apply/idP/mapsP => [Hx|[y Hy <-]].
    exists (finv h x); last by apply f_finv.
    by rewrite /ea filter_enum (fclosed1 Ha) f_finv.
  by move: Hy; rewrite /ea filter_enum (fclosed1 Ha).
  rewrite {Ha Ea}(eq_sumz_r Ea f) {1}/sumz -/ea.
have Uea: (uniq ea) by exact (uniq_filter _ (uniq_enum d)).
elim: {a}ea Uea => [|x p Hrec]; rewrite /= ?sumz0 //.
move/andP=> [Hx Up]; rewrite {Hrec Up}(Hrec Up).
apply: (etrans _ (esym (sumz_setID (eqd (h x)) _ _))); congr addz.
  rewrite -(eq_sumz_r (a := eqd (h x))) ?sumz_set1 // /setU1 /setI.
  by move=> y /=; case (h x =d y); rewrite ?andbF.
apply: eq_sumz_r => [y]; rewrite /setD /setU1.
by case: (h x =P y) => // <-; rewrite (mem_maps Hh) (negbE Hx).
Qed.

End ZnatSums.

Unset Implicit Arguments.


Require Import BagsInterface AdditionalLemmas.
Require Import AdditionalMorphisms.

Section BagsProperties.

  Context
    {BagType TItem SearchTermType UpdateTermType : Type}
    (bag          : Bag BagType TItem SearchTermType UpdateTermType)
    (RepInv       : BagType -> Prop)
    (ValidUpdate  : UpdateTermType -> Prop)
    (valid_bag    : CorrectBag RepInv ValidUpdate bag).

  Lemma binsert_enumerate_weak
  : forall item inserted container,
      RepInv container ->
      (List.In item (benumerate (binsert container inserted)) <->
      List.In item (benumerate container) \/ item = inserted).
  Proof.
    intros.
    rewrite <- refold_in.
    apply in_permutation_morphism; eauto using binsert_enumerate.
  Qed.

  Lemma benumerate_empty_eq_nil
  : benumerate bempty = nil.
  Proof.
    pose proof (benumerate_empty) as not_in;
    unfold BagEnumerateEmpty in not_in.
    destruct (benumerate bempty) as [ | item ? ];
      simpl in *;
      [ | exfalso; apply (not_in item) ];
      eauto.
  Qed.

  Lemma binsert_enumerate_length
  : forall (bag: BagType) (item: TItem),
      RepInv bag ->
      List.length (benumerate (binsert bag item)) = S (List.length (benumerate bag)).
  Proof.
    intros; rewrite binsert_enumerate; simpl; trivial.
  Qed.

  Definition _bcount container item :=
    List.length (List.filter (fun x => if bfind_matcher item x then true else false) (benumerate container)).

  Definition _BagInsertCount :=
    forall (search_term : SearchTermType) (item : TItem) (container : BagType),
      RepInv container ->
      _bcount (binsert container item) search_term =
      _bcount container search_term + if bfind_matcher search_term item then 1 else 0.

  Definition _BagCountEmpty :=
    forall item, _bcount bempty item = 0.

  Lemma _bcount_empty :
      _BagCountEmpty.
  Proof.
    unfold _BagCountEmpty, _bcount; intros.
    rewrite benumerate_empty_eq_nil; simpl; trivial.
  Qed.

  Lemma _binsert_count : _BagInsertCount.
  Proof.
    unfold _BagInsertCount, _bcount; intros;
    rewrite binsert_enumerate; simpl; destruct (bfind_matcher search_term item); simpl;
    eauto; omega.
  Qed.

End BagsProperties.


From Cat Require Export Cat.
From Cat.Universal Require Import Initial Terminal Product Coproduct.
From Cat Require Export Instances.SETOID.

Set Implicit Arguments.

Class Sgr : Type :=
{
  setoid :> Setoid';
  op : carrier -> carrier -> carrier;
  Proper_op :> Proper (equiv ==> equiv ==> equiv) op;
  assoc : forall x y z : carrier, op x (op y z) == op (op x y) z
}.

Coercion setoid : Sgr >-> Setoid'.

Class SgrHom (A B : Sgr) : Type :=
{
  setoidHom :> SetoidHom A B;
  pres_op : forall x y : A, setoidHom (op x y) == op (setoidHom x) (setoidHom y)
}.

Coercion setoidHom : SgrHom >-> SetoidHom.

Inductive exp (X : Sgr) : Type :=
| Var : X -> exp X
| Op : exp X -> exp X -> exp X
| Mor : forall A : Sgr, SgrHom A X -> exp A -> exp X.

Arguments Var [X] _.
Arguments Op [X] _ _.
Arguments Mor [X A] _ _ .

Fixpoint expDenote {X : Sgr} (e : exp X) : X :=
match e with
| Var v => v
| Op e1 e2 => op (expDenote e1) (expDenote e2)
| Mor f e' => f (expDenote e')
end.

Fixpoint simplify {X : Sgr} (e : exp X) : exp X :=
match e with
| Var v => Var v
| Op e1 e2 => Op (simplify e1) (simplify e2)
| Mor f e' =>
  match simplify e' with
  | Op e1' e2' => Op (Mor f e1') (Mor f e2')
  | e'' => Mor f e''
  end
end.

Lemma simplify_correct :
  forall (X : Sgr) (e : exp X),
    expDenote (simplify e) == expDenote e.
Proof.
  induction e; cbn; [easy | |].
  - now rewrite IHe1, IHe2.
  - now destruct (simplify e); cbn in *; rewrite <- IHe, ?pres_op.
Qed.

Fixpoint expDenoteNel {X : Sgr} (l : Nel X) : X :=
match tl l with
| None => hd l
| Some t => op (hd l) (expDenoteNel t)
end.

Lemma expDenoteNel_napp :
  forall (X : Sgr) (l1 l2 : Nel X),
    expDenoteNel (napp l1 l2) == op (expDenoteNel l1) (expDenoteNel l2).
Proof.
  induction l1 as [| h1 t1] using Nel_ind'; cbn; intros; [easy |].
  now rewrite IHt1, assoc.
Qed.

Lemma expDenoteNel_hom :
  forall (X Y : Sgr) (f : SgrHom X Y) (l : Nel X),
    expDenoteNel (nmap f l) == f (expDenoteNel l).
Proof.
  induction l as [| h t] using Nel_ind'; cbn; [easy |].
  now rewrite pres_op, IHt.
Qed.

Fixpoint flatten {X : Sgr} (e : exp X) : Nel X :=
match e with
| Var v => Cons v None
| Op e1 e2 => napp (flatten e1) (flatten e2)
| Mor f e' => nmap f (flatten e')
end.

Lemma flatten_correct :
  forall (X : Sgr) (e : exp X),
    expDenoteNel (flatten e) == expDenote e.
Proof.
  induction e; cbn; [easy | |].
  - now rewrite expDenoteNel_napp, IHe1, IHe2.
  - now rewrite expDenoteNel_hom, IHe.
Qed.

Lemma sgr_reflect :
  forall (X : Sgr) (e1 e2 : exp X),
    expDenoteNel (flatten (simplify e1)) ==
    expDenoteNel (flatten (simplify e2)) ->
      expDenote e1 == expDenote e2.
Proof.
  now intros; rewrite !flatten_correct, !simplify_correct in H.
Qed.

Class Reify (X : Sgr) (x : X) : Type :=
{
  reify : exp X;
  reify_spec : expDenote reify == x
}.

Arguments Reify {X} _.
Arguments reify {X} _ {Reify}.

#[refine]
#[export]
Instance ReifyVar (X : Sgr) (x : X) : Reify x | 1 :=
{
  reify := Var x
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance ReifyOp (X : Sgr) (a b : X) (Ra : Reify a) (Rb : Reify b) : Reify (@op X a b) | 0 :=
{
  reify := Op (reify a) (reify b)
}.
Proof.
  now cbn; rewrite !reify_spec.
Defined.

#[refine]
#[export]
Instance ReifyMor (X Y : Sgr) (f : SgrHom X Y) (x : X) (Rx : Reify x) : Reify (f x) | 0 :=
{
  reify := Mor f (reify x)
}.
Proof.
  now cbn; rewrite !reify_spec.
Defined.

Ltac reflect_sgr := cbn; intros;
match goal with
| |- ?e1 == ?e2 =>
  change (expDenote (reify e1) == expDenote (reify e2));
  apply sgr_reflect; cbn
end.

Ltac reflect_sgr' :=
  intros;
  do 2 (rewrite <- reify_spec; symmetry);
  apply sgr_reflect; cbn.

Ltac sgr_simpl := repeat red; cbn in *; intros.

Ltac sgrob S := try intros until S;
match type of S with
| Sgr =>
  let a := fresh S "_op" in
  let a' := fresh S "_Proper_op" in
  let b := fresh S "_assoc" in destruct S as [S a a' b]; setoidob S
| Ob _ => progress cbn in S; sgrob S
end; sgr_simpl.

Ltac sgrobs := repeat
match goal with
| S : Sgr |- _ => sgrob S
| S : Ob _ |- _ => sgrob S
end; sgr_simpl.

Ltac sgrhom f := try intros until f;
match type of f with
| SgrHom _ _ =>
    let a := fresh f "_pres_op" in destruct f as [f a];
    cbn in *; setoidhom f
| Hom _ _ => progress cbn in f; sgrhom f
end; sgr_simpl.

Ltac sgrhoms := intros; repeat
match goal with
| f : SgrHom _ _ |- _ => sgrhom f
| f : Hom _ _ |- _ => sgrhom f
| _ => idtac
end; sgr_simpl.

Ltac sgr := intros; try (reflect_sgr; try reflexivity; fail); repeat
match goal with
| |- _ == _ => now reflect_sgr
| |- Equivalence _ => solve_equiv
| |- Proper _ _ => proper
| _ => sgr_simpl || sgrobs || sgrhoms || cat
end.

Goal
  forall (X : Sgr) (a b c : X),
    op a (op b c) == op (op a b) c.
Proof.
  now reflect_sgr.
Qed.

Goal
  forall (X : Sgr) (f : SgrHom X X) (a b : X),
    f (op a b) == op (f a) (f b).
Proof.
  now reflect_sgr.
Qed.

#[refine]
#[export]
Instance SgrHomSetoid (X Y : Sgr) : Setoid (SgrHom X Y) :=
{
  equiv := fun f g : SgrHom X Y => forall x : X, f x == g x
}.
Proof. now sgr. Defined.

Definition SgrComp (A B C : Sgr) (f : SgrHom A B) (g : SgrHom B C) : SgrHom A C.
Proof.
  exists (SetoidComp f g); cbn.
  now intros; rewrite !pres_op.
Defined.

Definition SgrId (A : Sgr) : SgrHom A A.
Proof.
  now exists (SetoidId A).
Defined.

#[refine]
#[export]
Instance SgrCat : Cat :=
{
  Ob := Sgr;
  Hom := SgrHom;
  HomSetoid := SgrHomSetoid;
  comp := SgrComp;
  id := SgrId
}.
Proof. all: now sgr. Defined.

#[refine]
#[export]
Instance Sgr_init : Sgr :=
{
  setoid := SETOID_init;
  op := fun (e : Empty_set) _ => match e with end
}.
Proof. all: easy. Defined.

Definition Sgr_create (X : Sgr) : Hom Sgr_init X.
Proof.
  now exists (SETOID_create X).
Defined.

#[refine]
#[export]
Instance HasInit_Sgr : HasInit SgrCat :=
{
  init := Sgr_init;
  create := Sgr_create
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Sgr_term : Sgr :=
{
  setoid := SETOID_term;
  op := fun _ _ => tt
}.
Proof. all: easy. Defined.

Definition Sgr_delete (X : Sgr) : Hom X Sgr_term.
Proof.
  now exists (SETOID_delete X).
Defined.

#[refine]
#[export]
Instance HasTerm_Sgr : HasTerm SgrCat :=
{
  term := Sgr_term;
  delete := Sgr_delete
}.
Proof. easy. Defined.

#[refine]
#[export]
Instance Sgr_product (X Y : Sgr) : Sgr :=
{
  setoid := SETOID_product X Y;
  op := fun x y => (op (fst x) (fst y), op (snd x) (snd y))
}.
Proof.
  - intros [f1 Hf1] [f2 Hf2] [Hf1' Hf2'] [g1 Hg1] [g2 Hg2] [Hg1' Hg2']; cbn in *.
    now rewrite Hf1', Hf2', Hg1', Hg2'.
  - intros [x1 y1] [x2 y2] [x3 y3]; cbn.
    now rewrite !assoc.
Defined.

Definition Sgr_outl (X Y : Sgr) : SgrHom (Sgr_product X Y) X.
Proof.
  now exists (SETOID_outl X Y).
Defined.

Definition Sgr_outr (X Y : Sgr) : SgrHom (Sgr_product X Y) Y.
Proof.
  now exists (SETOID_outr X Y).
Defined.

Definition Sgr_fpair (A B X : Sgr) (f : SgrHom X A) (g : SgrHom X B)
    : SgrHom X (Sgr_product A B).
Proof.
  exists (SETOID_fpair f g); cbn.
  now intros; rewrite !pres_op.
Defined.

#[refine]
#[export]
Instance HasProducts_Sgr : HasProducts SgrCat :=
{
  product := Sgr_product;
  outl := Sgr_outl;
  outr := Sgr_outr;
  fpair := Sgr_fpair
}.
Proof.
  now repeat split; cbn in *.
Defined.

Inductive SCE {A B : Sgr} : Nel (A + B) -> Nel (A + B) -> Prop :=
| SCE_refl :
  forall l : Nel (A + B), SCE l l
| SCE_sym :
  forall l1 l2 : Nel (A + B),
    SCE l1 l2 -> SCE l2 l1
| SCE_trans :
  forall l1 l2 l3 : Nel (A + B),
    SCE l1 l2 -> SCE l2 l3 -> SCE l1 l3
| SCE_hd :
  forall {h1 h2 : A + B}, h1 == h2 -> SCE (Cons h1 None) (Cons h2 None)
| SCE_cons :
  forall {h1 h2 : A + B} {t1 t2 : Nel (A + B)},
    h1 == h2 -> SCE t1 t2 -> SCE (Cons h1 (Some t1)) (Cons h2 (Some t2))
| SCE_cons_op_l :
  forall (a1 a2 : A) (t : option (Nel (A + B))),
    SCE (Cons (inl a1) (Some (Cons (inl a2) t))) (Cons (inl (op a1 a2)) t)
| SCE_cons_op_r :
  forall (b1 b2 : B) (t : option (Nel (A + B))),
    SCE (Cons (inr b1) (Some (Cons (inr b2) t))) (Cons (inr (op b1 b2)) t).

#[export] Hint Constructors SCE : core.

#[export]
Instance Equivalence_SCE :
  forall A B : Sgr,
    Equivalence (@SCE A B).
Proof.
  split; red.
  - now apply SCE_refl.
  - now apply SCE_sym.
  - now apply SCE_trans.
Defined.

Lemma SCE_app_l :
  forall (A B : Sgr) (l l1 l2 : Nel (A + B)),
    SCE l1 l2 -> SCE (napp l l1) (napp l l2).
Proof.
  induction l as [h | h t] using Nel_ind'; cbn; intros.
  - now apply SCE_cons.
  - now apply SCE_cons; [| apply IHt].
Qed.

Lemma SCE_app :
  forall {A B : Sgr} (l11 l12 l21 l22 : Nel (A + B)),
    SCE l11 l12 -> SCE l21 l22 -> SCE (napp l11 l21) (napp l12 l22).
Proof.
  intros * H1 H2; revert l21 l22 H2.
  induction H1; cbn; intros.
  - now apply SCE_app_l.
  - now eauto.
  - now eauto.
  - now eauto.
  - now eauto.
  - rewrite SCE_cons_op_l.
    now destruct t; apply SCE_cons; [| apply SCE_app_l | |].
  - rewrite SCE_cons_op_r.
    now destruct t; apply SCE_cons; [| apply SCE_app_l | |].
Defined.

#[export]
Instance Sgr_coproduct_Setoid' (A B : Sgr) : Setoid' :=
{
  carrier := Nel (A + B);
  setoid :=
  {|
    equiv := SCE;
    setoid_equiv := Equivalence_SCE A B;
  |};
}.

#[refine]
#[export]
Instance Sgr_coproduct (A B : Sgr) : Sgr :=
{
  setoid := Sgr_coproduct_Setoid' A B;
  op := fun l1 l2 => napp l1 l2;
}.
Proof.
  - intros l1 l1' H1 l2 l2' H2; cbn in *.
    now apply SCE_app.
  - now cbn; intros; rewrite napp_assoc.
Defined.

#[export]
Instance Sgr_finl' (A B : Sgr) : SetoidHom A (Sgr_coproduct A B).
Proof.
  split with (fun a => Cons (inl a) None).
  now constructor.
Defined.

#[export]
Instance Sgr_finl {A B : Sgr} : SgrHom A (Sgr_coproduct A B).
Proof.
  split with (Sgr_finl' A B); cbn.
  now intros; rewrite SCE_cons_op_l.
Defined.

#[export]
Instance Sgr_finr' (A B : Sgr) : SetoidHom B (Sgr_coproduct A B).
Proof.
  split with (fun b => Cons (inr b) None).
  now constructor.
Defined.

#[export]
Instance Sgr_finr {A B : Sgr} : SgrHom B (Sgr_coproduct A B).
Proof.
  split with (Sgr_finr' A B); cbn.
  now intros; rewrite SCE_cons_op_r.
Defined.

Fixpoint Sgr_copair'
  {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) (l : Nel (A + B)) : X :=
match tl l with
| None =>
  match hd l with
  | inl a => f a
  | inr b => g b
  end
| Some t =>
  match hd l with
  | inl a => op (f a) (Sgr_copair' f g t)
  | inr b => op (g b) (Sgr_copair' f g t)
  end
end.

Lemma Sgr_copair'_app :
  forall {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) (l1 l2 : Nel (A + B)),
    Sgr_copair' f g (napp l1 l2) == op (Sgr_copair' f g l1) (Sgr_copair' f g l2).
Proof.
  now induction l1 as [[] | [] t] using Nel_ind'; cbn; intros; rewrite ?IHt, ?assoc.
Qed.

#[export]
Instance Sgr_copair_Setoid'
  {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) : SetoidHom (Sgr_coproduct A B) X.
Proof.
  esplit with (Sgr_copair' f g).
  intros l1 l2 Heq; cbn in *.
  induction Heq; cbn.
  - easy.
  - easy.
  - now rewrite IHHeq1, IHHeq2.
  - destruct h1, h2; cbn in *; [| easy | easy |].
    + now rewrite H.
    + now rewrite H.
  - destruct h1, h2; cbn in *; [| easy | easy |].
    + now rewrite H, IHHeq.
    + now rewrite H, IHHeq.
  - now destruct t as [t |]; rewrite pres_op, ?assoc.
  - now destruct t as [t |]; rewrite pres_op, ?assoc.
Defined.

#[export]
Instance Sgr_copair
  {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) : SgrHom (Sgr_coproduct A B) X.
Proof.
  esplit with (Sgr_copair_Setoid' f g); cbn.
  now intros; rewrite Sgr_copair'_app.
Defined.

#[refine]
#[export]
Instance HasCoproducts_Sgr : HasCoproducts SgrCat :=
{
  coproduct := @Sgr_coproduct;
  finl := @Sgr_finl;
  finr := @Sgr_finr;
  copair := @Sgr_copair;
}.
Proof.
  split; cbn.
  - easy.
  - easy.
  - intros P' h1 h2 HA HB l.
    induction l as [[a | b] | h t] using Nel_ind'; cbn.
    + now apply HA.
    + now apply HB.
    + change {| hd := h; tl := Some t; |} with (@op (Sgr_coproduct A B) (Cons h None) t).
      now rewrite (@pres_op _ _ h1), (@pres_op _ _ h2), IHt; destruct h; rewrite ?HA, ?HB.
Defined.

#[refine]
#[export]
Instance Sgr_equalizer {A B : Sgr} (f g : SgrHom A B) : Sgr :=
{
  setoid := SETOID_equalizer f g;
}.
Proof.
  - cbn; intros [x Hx] [y Hy].
    exists (op x y).
    now rewrite !pres_op, Hx, Hy.
  - intros [a1 H1] [a2 H2] Heq1 [a3 H3] [a4 H4] Heq2; cbn in *.
    now rewrite Heq1, Heq2.
  - intros [x Hx] [y Hy] [z Hz]; cbn in *.
    now rewrite assoc.
Defined.

#[refine]
#[export]
Instance Sgr_equalize {A B : Sgr} (f g : SgrHom A B) : SgrHom (Sgr_equalizer f g) A :=
{
  setoidHom := SETOID_equalize f g;
}.
Proof.
  now intros [x Hx] [y Hy]; cbn.
Defined.

#[export]
#[refine]
Instance Sgr_factorize
  {A B : Sgr} {f g : SgrHom A B}
  {E' : Sgr} (e' : Hom E' A) (Heq : (e' .> f) == (e' .> g))
  : SgrHom E' (Sgr_equalizer f g) :=
{
  setoidHom := SETOID_factorize e' Heq;
}.
Proof.
  now cbn; intros; rewrite pres_op.
Defined.

#[refine]
#[export]
Instance HasEqualizers_Sgr : HasEqualizers SgrCat :=
{
  equalizer := @Sgr_equalizer;
  equalize := @Sgr_equalize;
  factorize := @Sgr_factorize;
}.
Proof.
  split; cbn.
  - now intros [x H]; cbn.
  - easy.
  - easy.
Defined.

Inductive Sgr_coeq_equiv {A B : Sgr} (f g : SgrHom A B) : B -> B -> Prop :=
| SgrCE_quot : forall a : A, Sgr_coeq_equiv f g (f a) (g a)
| SgrCE_op   :
  forall {l1 r1 l2 r2 : B},
    Sgr_coeq_equiv f g l1 l2 ->
    Sgr_coeq_equiv f g r1 r2 ->
      Sgr_coeq_equiv f g (op l1 r1) (op l2 r2)
| SgrCE_refl : forall {b1 b2 : B}, b1 == b2 -> Sgr_coeq_equiv f g b1 b2
| SgrCE_sym  :
  forall {b1 b2 : B}, Sgr_coeq_equiv f g b1 b2 -> Sgr_coeq_equiv f g b2 b1
| SgrCE_trans :
  forall {b1 b2 b3 : B},
    Sgr_coeq_equiv f g b1 b2 ->
    Sgr_coeq_equiv f g b2 b3 ->
      Sgr_coeq_equiv f g b1 b3.

#[export] Hint Constructors Sgr_coeq_equiv : core.

#[export]
Instance Equivalence_Sgr_coeq_equiv
  {A B : Sgr} (f g : SgrHom A B) : Equivalence (Sgr_coeq_equiv f g).
Proof.
  split; red.
  - now constructor.
  - now apply SgrCE_sym.
  - now intros; apply SgrCE_trans with y.
Defined.

#[export]
Instance Sgr_coequalizer_Setoid {A B : Sgr} (f g : SgrHom A B) : Setoid' :=
{
  carrier := B;
  Setoids.setoid :=
  {|
    equiv := Sgr_coeq_equiv f g;
  |};
}.

#[refine]
#[export]
Instance Sgr_coequalizer {A B : Sgr} (f g : SgrHom A B) : Sgr :=
{
  setoid := Sgr_coequalizer_Setoid f g;
  op := op;
}.
Proof.
  - intros x1 x2 H12 x3 x4 H34; cbn in *.
    now constructor.
  - cbn; intros.
    apply SgrCE_refl.
    now rewrite assoc.
Defined.

#[refine]
#[export]
Instance Sgr_coequalize' {A B : Sgr} (f g : SgrHom A B) : SetoidHom B (Sgr_coequalizer f g) :=
{
  func := fun b => b;
}.
Proof.
  intros b1 b2 Heq; cbn.
  now constructor.
Defined.

#[refine]
#[export]
Instance Sgr_coequalize {A B : Sgr} {f g : SgrHom A B} : SgrHom B (Sgr_coequalizer f g) :=
{
  setoidHom := Sgr_coequalize' f g;
}.
Proof.
  now constructor; cbn.
Defined.

#[export]
#[refine]
Instance Sgr_cofactorize'
  {A B : Sgr} {f g : Hom A B}
  {Q : Sgr} (q : Hom B Q) (Heq : f .> q == g .> q)
  : SetoidHom (Sgr_coequalizer f g) Q :=
{
  func := q;
}.
Proof.
  intros x y H. cbn in *.
  induction H.
  - easy.
  - now rewrite !pres_op, IHSgr_coeq_equiv1, IHSgr_coeq_equiv2.
  - now rewrite H.
  - now symmetry.
  - now transitivity (q b2).
Defined.

#[export]
#[refine]
Instance Sgr_cofactorize
  {A B : Sgr} {f g : Hom A B}
  {Q : Sgr} (q : Hom B Q) (Heq : f .> q == g .> q)
  : SgrHom (Sgr_coequalizer f g) Q :=
{
  setoidHom := Sgr_cofactorize' Heq;
}.
Proof.
  now cbn; intros; rewrite pres_op.
Defined.

#[refine]
#[export]
Instance HasCoequalizers_Sgr : HasCoequalizers SgrCat :=
{
  coequalizer := @Sgr_coequalizer;
  coequalize := @Sgr_coequalize;
  cofactorize := @Sgr_cofactorize;
}.
Proof.
  split; cbn.
  - now constructor.
  - easy.
  - easy.
Defined.

#[refine]
#[export]
Instance Sgr_pullback
  {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) : Sgr :=
{
  setoid := SETOID_pullback f g;
}.
Proof.
  - intros [a1 b1 H1] [a2 b2 H2]; cbn.
    refine {| pullL := op a1 a2; pullR := op b1 b2; |}.
    now rewrite !pres_op, H1, H2.
  - intros [a1 b1 H1] [a2 b2 H2] [Ha12 Hb12] [a3 b3 H3] [a4 b4 H4] [Ha34 Hb34]; cbn in *.
    now rewrite Ha12, Hb12, Ha34, Hb34.
  - intros [a1 b1 H1] [a2 b2 H2] [a3 b3 H3]; cbn.
    now rewrite !assoc.
Defined.

#[refine]
#[export]
Instance Sgr_pullL
  {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) : SgrHom (Sgr_pullback f g) A :=
{
  setoidHom := SETOID_pullL;
}.
Proof.
  now intros [a1 b1 H1] [a2 b2 H2]; cbn.
Defined.

#[refine]
#[export]
Instance Sgr_pullR
  {A B X : Sgr} (f : SgrHom A X) (g : SgrHom B X) : SgrHom (Sgr_pullback f g) B :=
{
  setoidHom := SETOID_pullR;
}.
Proof.
  now intros [a1 b1 H1] [a2 b2 H2]; cbn.
Defined.

#[refine]
#[export]
Instance Sgr_triple
  {A B X : Sgr} (f : Hom A X) (g : Hom B X)
  {Γ : Sgr} (a : Hom Γ A) (b : Hom Γ B) (Heq : a .> f == b .> g)
  : SgrHom Γ (Sgr_pullback f g) :=
{
  setoidHom := SETOID_triple a b Heq;
}.
Proof.
  now cbn; intros; rewrite !pres_op.
Defined.

#[refine]
#[export]
Instance HasPullbacks_Sgr : HasPullbacks SgrCat :=
{
  pullback := @Sgr_pullback;
  pullL    := @Sgr_pullL;
  pullR    := @Sgr_pullR;
  triple   := @Sgr_triple;
}.
Proof.
  split; cbn.
  - now apply ok.
  - easy.
  - easy.
  - now split.
Defined.

(* We construct pushouts from coproducts and coequalizers. *)
#[export] Instance HasPushouts_Sgr : HasPushouts SgrCat :=
  HasPushouts_HasCoproducts_HasCoequalizers HasCoproducts_Sgr HasCoequalizers_Sgr.