Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrnat.

Generalizable All Variables.
Set Implicit Arguments.
Unset Strict Implicit.

Import Prenex Implicits.

Module ITree.
  Section Syntax.
    Context (E : Type -> Type).
    Context (R : Type).

    Inductive itreeF (itree : Type) : Type :=
    | Vis {A} (e : E A) (k : A -> itree)
    | Tau (i : itree)
    | Ret (r : R)
    .

    Set Primitive Projections.
    CoInductive itree := go { observe : itreeF itree }.
    Unset Primitive Projections.

    Inductive ftree := fgo { fobserve : itreeF ftree }.
  End Syntax.

  Arguments Vis {E R itree A} e k.
  Arguments Tau {E R itree} i.
  Arguments Ret {E R itree} r.

  Section Peek.
    Context (E : Type -> Type).
    Context (R : Type).

  Definition inf_run (i : itree E R) : itreeF E R (itree E R) :=
    match observe i with
    | Vis _ e k => Vis e k
    | Tau t => observe t
    | Ret r => Ret r
    end.

  Definition fin_run (i : ftree E R) : itreeF E R (ftree E R) :=
    fobserve i.

  End Peek.

  Module LocalTypes.
    Definition P := nat.

    Inductive LTy (A : Type) := | LSend (p : P) | LRecv (p : P).

    Record class (T : Type) :=
      Class {
          t_run : T -> itreeF LTy Type T;
          mk_send : forall A, P -> (A -> T) -> T;
          mk_recv : forall A, P -> (A -> T) -> T;
          mk_end : Type -> T;
          mk_impossible : Type -> T;
        }.

    Structure type : Type := Pack { tree :> Type; class_of : class tree }.
    Definition run (t : type) : tree t -> itreeF LTy Type (tree t)
      := let 'Pack _ (Class the_op _ _ _ _) := t in the_op.
    Definition send (t : type) : forall A, P -> (A -> tree t) -> tree t
      := let 'Pack _ (Class _ the_op _ _ _) := t in the_op.
    Definition recv (t : type) : forall A, P -> (A -> tree t) -> tree t
      := let 'Pack _ (Class _ _ the_op _ _) := t in the_op.
    Definition stop (t : type) : Type -> tree t
      := let 'Pack _ (Class _ _ _ the_op _) := t in the_op.
    Definition impossible (t : type) : Type -> tree t
      := let 'Pack _ (Class _ _ _ _ the_op) := t in the_op.

    Definition inf_ltyC : class (itree LTy Type) :=
      {|
        t_run := @inf_run LTy Type;
        mk_impossible := fun _ => cofix spin := go (Tau spin);
        mk_send := fun A p f => go (Vis (LSend A p) f);
        mk_recv := fun A p f => go (Vis (LRecv A p) f);
        mk_end := fun (x : Type) => go (Ret x);
      |}.

    Canonical Structure inf_lty : type := @Pack (itree LTy Type) inf_ltyC.

    Definition fin_ltyC : class (ftree LTy Type) :=
      {|
        t_run := @fin_run LTy Type;
        mk_impossible := fun x => fgo (Tau (fgo (Ret x)));
        mk_send := fun A p f => fgo (Vis (LSend A p) f);
        mk_recv := fun A p f => fgo (Vis (LRecv A p) f);
        mk_end := fun (x : Type) => fgo (Ret x);
      |}.

    Canonical Structure fin_lty : type := @Pack (ftree LTy Type) fin_ltyC.

    Arguments send [t] A _ _.
    Arguments recv [t] A _ _.
    Arguments stop [t] A.
    Arguments impossible [t] A.

    Declare Scope lty_scope.
    Delimit Scope lty_scope with lty.
    Notation "X '<-' p '!!' e ';;' K" :=
      (send e p (fun X => K))
        (at level 60, right associativity) : lty_scope.
    Notation "X '@@' P '<-' p '!!' e ';;' K" :=
      (send e p (fun X =>
                   match X with
                   | P => K
                   | _ => impossible unit
                   end))
        (at level 60, P pattern, right associativity) : lty_scope.
    Notation "X '<-' p '??' e ';;' K" :=
      (recv e p (fun X => K))
        (at level 60, right associativity) : lty_scope.
    Notation "X '@@' P '<-' p '??' e ';;' K" :=
      (recv e p (fun X =>
                   match X with
                   | P => K
                   | _ => impossible unit
                   end))
        (at level 60, P pattern, right associativity) : lty_scope.

    Definition lty := type.
    About run.
  End LocalTypes.

  Section WellTypedProcesses.
    Import LocalTypes.

    Variable E : Type -> Type.
    Variable T : lty.

    Inductive ev (l : T) : forall A, (A -> T) -> Type :=
    | E_send {A} x p k (H : Vis (LSend A p) k = run l) : @ev l unit (fun _ => k x)
    | E_recv {A} p k (H : Vis (LRecv A p) k = run l) : @ev l A k
    | E_run {A} (e : E A) : @ev l A (fun _ =>l).
    Arguments E_send & [l A] x p [k] H.
    Arguments E_recv & [l A] p [k] H.
    Arguments E_run & [l A] e.

    Inductive procF (proc : T -> Type) : T -> Type :=
    | P_ev {A k l} (e : @ev l A k) (kp : forall x, proc (k x)) : procF proc l
    | P_call {l1} (k : proc l1) {l2} (_ : run l1 = run l2) : procF proc l2
    | P_end {A : Type} (x : A) l (_ : Ret A = run l) : procF proc l.
    Arguments P_ev [proc A k] & {l} e kp.
    Arguments P_call [proc l1] k & {l2} H.
    Arguments P_end [proc A] x & [l] _.

    CoInductive proc (l : T) : Type :=
      Go { observeP : procF proc l }.
    Arguments Go & [l].

    Definition p_send {A} (x : A) (p : P)
               l kl (H : Vis (LSend A p) kl = run l)
               (k : unit -> proc (kl x))
      : proc l := Go (P_ev (E_send x p H) k).
    Arguments p_send [A] x p & [l kl] H.

    Definition p_recv {A} (p : P)
               l kl (H : Vis (LRecv A p) kl = run l)
               (k : forall x, proc (kl x))
      : proc l := Go (P_ev (E_recv p H) k).
    Arguments p_recv [A] p & [l kl] H k.

    Definition p_call {l1} (k : proc l1) {l2} (H : run l1 = run l2) : proc l2
      := Go (P_call k H).
    Arguments p_call [l1] k & {l2} H.

    Definition pure [A : Type] (x : A) l (H : Ret A = run l) : proc l :=
      Go (P_end x H).
    Arguments pure [A] x & [l] _.

    Definition ifB {l1 l2} (b : bool) (p1 : proc l1) (p2 : proc l2)
      : proc (if b then l1 else l2)
      := match b as b0 return proc (if b0 then _ else _)
         with
         | true => p1
         | false => p2
         end.
    Arguments ifB & [l1 l2] b p1 p2.
  End WellTypedProcesses.

  Section Testing.
    Import LocalTypes.
    Definition runs_ok (l : itree LTy Type) : Prop :=
      match inf_run l with
      | Vis _ _ _ => True
      | Ret _ => True
      | Tau _ => False
      end.

    Lemma wrap_unwrap (t : itree LTy Type) (H : runs_ok t) :
      inf_run t = inf_run (go (inf_run t)).
    Proof. by move: H; rewrite /runs_ok; case: (inf_run t). Qed.

    Variable E : Type -> Type.

    CoFixpoint run_lty {l} (P : proc E l) : proc E (go (run l)).
    move: P => /observeP; case.
    - move=>A k {}l []/=.
      + move=> {}A x p {}k <- kp; apply/Go/(P_ev _ kp).
        by apply/(E_send (l := go (Vis (LSend A p) k)) E x Logic.eq_refl).
      + move=> {}A   p {}k <- kp; apply/Go/(P_ev _ kp).
        by apply/(E_recv (l := go (Vis (LRecv A p) k)) E   Logic.eq_refl).
      + move=> {k}A e kp; apply/Go/(P_ev _ (fun x => run_lty _ (kp x))).
        by apply/(E_run _ e).
    - move=>{l}l1 pl l2 Heq.
      move: (run_lty _ pl)=>{}pl.
      apply/Go/(P_call E pl).
      by rewrite Heq.
    - move=>{}A x {}l Heq.
      apply/Go/(P_end E (@proc E inf_lty) x).
      by rewrite -Heq.
    Defined.

  End Testing.

  Arguments E_send & [E T l A] x p [k] H.
  Arguments E_recv & [E T l A] p [k] H.
  Arguments E_run & [E T l A] e.
  Arguments P_ev [E T proc A k] & [l] e kp.
  Arguments P_end [E T proc A] x & [l] _.
  Arguments Go & [E T l].
  Arguments p_send [E T A] x p & [l kl] H k.
  Arguments p_recv [E T A] p & [l kl] H k.
  Arguments p_call [E T l1] k & {l2} H.
  Arguments pure [E T A] x & [l] _.
  Arguments ifB & [E T l1 l2] b p1 p2.

  Declare Scope expr_scope.
  Bind Scope expr_scope with proc.
  Delimit Scope expr_scope with expr.
  Notation "'RET' x" := (pure x Logic.eq_refl) (at level 60) : expr_scope.
  Notation "'CALL' x" := (p_call x Logic.eq_refl) (at level 60) : expr_scope.
  Notation "p '!' e ';;' K" :=
    (p_send e p Logic.eq_refl (fun _ =>K))
      (right associativity, at level 60) : expr_scope.
  Notation "x '<-' p '?' ';;' K" :=
    (p_recv p Logic.eq_refl (fun x => K))
      (right associativity, at level 60) : expr_scope.
  Notation "'if' b 'then' p1 'else' p2" := (ifB b p1 p2) : expr_scope.
End ITree.

Module EraseExtract.
  Require Extraction.
  Require Import ExtrOcamlBigIntConv.
  Import ITree.
  Extraction Implicit ev [l].
  Extraction Implicit E_send [E A l k H].
  Extraction Implicit E_recv [E A l k H].
  Extraction Implicit P_ev [E A l k].
  Extraction Implicit P_end [E A l].
  Extraction Implicit ifB [E l1 l2].
  Extraction Inline ifB.
  Extraction Implicit p_send [E l kl].
  Extraction Inline p_send.
  Extraction Implicit p_recv [E l kl].
  Extraction Inline p_recv.
  Extraction Implicit p_recv [E l kl].
  Extraction Inline pure.
  Extraction Implicit Go [E l].
End EraseExtract.

Module Examples.
  Import ITree.
  Import LocalTypes.
  Definition p := 0.
  Open Scope lty_scope.
  CoFixpoint example : itree LTy Type :=
    n <- p !! nat ;;
      match n  with
      | 0 => stop bool
      | m.+1 => b <- p !! bool ;; example
      end.

  Fixpoint fexample (r : nat) : ftree LTy Type :=
    n <- p !! nat ;;
      match n with
      | 0 => stop bool
      | m.+1 => b <- p !! bool ;;
                  match r with
                  | 0 => stop nat
                  | r.+1 => fexample r
                  end
      end.
  Close Scope lty_scope.

  Open Scope expr_scope.
  Definition pure_proc := proc (fun _ => False).

  Fail CoFixpoint prog1 : pure_proc example
    := p ! 1 ;; p ! true ;; RET 1.

  Fail CoFixpoint prog1 : pure_proc example
    := p ! 1 ;; p ! true ;; p ! true ;; RET 1.

  Fail CoFixpoint prog1 : pure_proc example
    := p ! false ;; p ! 1 ;; p ! true ;; RET 1.

  CoFixpoint prog1 : pure_proc example
    := p ! 1 ;; p ! true ;; prog1.

  Fail CoFixpoint prog2 : pure_proc example
    := p ! 1 ;; p ! 1 ;; p ! true ;; p ! false ;; prog2.
  CoFixpoint prog2 : pure_proc example
    := p ! 1 ;; p ! true ;; p ! 2 ;; p ! false ;; prog2.
  Definition prog3 : pure_proc example
    := p ! 1 ;;
         (cofix cont :=
            p ! true ;; p ! 2 ;; cont).
  CoFixpoint prog4 (n : nat) : pure_proc example :=
    match n with
    | 0 => p ! 0 ;; RET true
    | m.+1 => p ! m.+1 ;; p ! false ;; prog4 m
    end.
  CoFixpoint prog5 (n : nat) : pure_proc example :=
    p ! n ;;
      match n with
      | 0 => RET true
      | m.+1 => p ! false ;; prog5 m
      end.

  Open Scope lty_scope.
  CoFixpoint example2 : itree LTy Type :=
    n <- p ?? nat ;;
      match n with
      | 0 => stop bool
      | m.+1 => b <- p !! bool ;; example2
      end.
  CoFixpoint prog21 : pure_proc example2 :=
    n <- p ? ;;
      match n with
      | 0 => RET true
      | m.+1 => p ! false ;; prog21
      end.
  Close Scope expr_scope.

  Open Scope lty_scope.
  CoFixpoint example3 : itree LTy Type :=
    n <- p ?? nat ;;
      if n > 27
      then stop bool
      else b <- p !! bool ;; example3.
  Close Scope lty_scope.

  Open Scope expr_scope.
  CoFixpoint prog31 : pure_proc example3
    := n <- p ? ;;
         if (n > 27)
         then RET true
         else p ! false ;; prog31.
  CoFixpoint prog32 : pure_proc example3
    := n <- p ? ;;
         if (n > 27)
         then RET true
         else p ! false ;;
                match (n > 28) with
                | true => prog31
                | false => prog32
                end.
  Close Scope expr_scope.
End Examples.

Module IOProc.
  Variant IO (A : Type) : Type :=
  | Read : IO A
  | Write (x : A) : IO A.

  Import ITree.

  Definition io_proc := proc IO.

  Notation "'write' e ';;' K" :=
    (Go (P_ev (E_run (Write e)) (fun _ => K)))
      (right associativity, at level 60) : expr_scope.
  Notation "X '<-' 'read' T ';;' K" :=
    (Go (P_ev (E_run (Read T)) (fun (X : T) => K)))
      (right associativity, at level 60) : expr_scope.
End IOProc.

Module PingPong.
  Import ITree.
  Import IOProc.
  Import LocalTypes.

  Open Scope lty_scope.
  CoFixpoint pp_client (p : P) : itree LTy Type :=
    n <- p !! option nat ;;
      match n with
      | None => stop unit
      | Some n => _ <- p ?? nat ;; pp_client p
      end.

  CoFixpoint pp_server (p : P) : itree LTy Type :=
    n <- p ?? option nat ;;
      match n with
      | None => stop unit
      | Some n => _ <- p !! nat ;; pp_server p
      end.

  Inductive PingTy := Ping (n : nat) | Close.

  Open Scope expr_scope.
  CoFixpoint some_client (p : P) : io_proc (pp_client p) :=
    n <- read PingTy ;;
    match n with
    | Ping n =>
      p ! Some n ;;
      x <- p ? ;;
      write (Ping n);;
      some_client p
    | Close => p ! None ;; write Close ;; RET tt
    end.

  Fixpoint weird_client (n : nat) (p : P) : io_proc (pp_client p) :=
    match n with
    | 0 => some_client p
    | m.+1 =>
      p ! Some m ;;
      _ <- p ? ;;
      weird_client m p
    end.

  Definition weirder_client (n : nat) (p : P) : io_proc (pp_client p) :=
      p ! Some 0 ;;
        cofix repeat_cli :=
          n <- p ? ;;
            match n < 42 with
            | true => p ! None ;; RET tt
            | false => p ! Some n ;;
                         repeat_cli
            end.

  CoFixpoint some_server (p : P) : io_proc (pp_server p) :=
    n <- p ? ;;
    match n with
    | Some x =>
      p ! x ;;
      some_server p
    | None => RET tt
    end.
  Close Scope expr_scope.

  Fixpoint fin_client (n : nat) (p : P) : ftree LTy Type :=
    match n with
    | 0    => x @@ None <- p !! option nat;; stop unit
    | m.+1 => x <- p !! option nat;;
                match x with
                | None => stop unit
                | Some _ => x <- p ?? nat;;
                              fin_client m p
                end
    end.

  (** One annoyance of protocols like below is that they MUST inspect
   * [n], othewise the protocol will not reduce. E.g. it is clear that
   * sending None ends the protocol. But due to [fix], Coq will not know
   * that unless it is applied to a constructor
   *)
  Definition fin_client_alt (n : nat) (p : P) : ftree LTy Type :=
    x  <- p !! option nat;;
       (fix rec (x : option nat) (n : nat) :=
          match x with
          | None => stop unit
          | Some _ =>
            match n with
            | 0 => impossible unit
            | m.+1 => x <- p ?? nat;;
                      x <- p !! option nat ;;
                      rec x m
            end
          end) x n.
  Close Scope lty_scope.
  Open Scope expr_scope.

  Inductive Option := Continue | Stop.
  Fixpoint weirdest_client (n : nat) (p : P) : io_proc (fin_client n p) :=
    match n with
    | 0 => p ! None ;; RET tt
    | m.+1 => a <- read Option;;
                match a with
                | Continue =>
                  p ! Some n ;;
                  _ <- p ? ;;
                  weirdest_client m p
                | Stop => p ! None ;; RET tt
                end
    end.
  Fixpoint weirdestest_client (n : nat) (p : P) : io_proc (fin_client_alt n p) :=
    match n with
    | 0 => p ! None ;; RET tt
    | m.+1 => a <- read Option;;
                match a with
                | Continue =>
                  p ! Some n ;;
                  _ <- p ? ;;
                  weirdestest_client m p
                | Stop => p ! None ;; RET tt
                end
    end.

  Fail Fixpoint weirdest_client1 (n : nat) (p : P) : io_proc (fin_client n p) :=
    match n with
    | 0 => p ! Some 0 ;; _ <- p ? ;; RET tt
    | m.+1 => p ! Some n ;; _ <- p ? ;; weirdest_client1 m p
    end.
  Fixpoint weirdest_client2 (n : nat) (p : P) : io_proc (fin_client n p) :=
    match n with
    | 0 => p ! None ;; RET tt
    | m.+1 => p ! None ;; RET tt
    end.

  Fixpoint weirdestest_client1 (n : nat) (p : P) : io_proc (fin_client_alt n p) :=
    p ! None ;;
      match n with
      | 0 => RET tt
      | m.+1 => RET tt
      end.
  Fail CoFixpoint weirdestest_client1 (n : nat) (p : P) : io_proc (fin_client_alt n p) :=
    p ! Some n ;;
      match n with
      | 0 => weirdestest_client1 0 p
      | m.+1 => _ <- p ? ;; weirdestest_client1 m p
      end.
End PingPong.

Module DependentProtocols.
  Import ITree.
  Import LocalTypes.
  Import IOProc.

  Open Scope lty_scope.
  Definition repeat_send (p : P) k : nat -> itree LTy Type :=
    cofix repeat_n n :=
      match n with
      | 0 => k
      | m.+1 => x <- p !! nat;; repeat_n m
      end.
  CoFixpoint request_n_tasks (p : P) : itree LTy Type :=
    n <- p ?? nat ;;
      repeat_send p (request_n_tasks p) n.
  Close Scope lty_scope.

  Definition Task := nat.
  Open Scope expr_scope.

  CoFixpoint example_server (p : P) : io_proc (request_n_tasks p)
    := n <- p ? ;;
         ((cofix rec n : io_proc (repeat_send p (request_n_tasks p) n) :=
             match n with
             | 0 => CALL (example_server p)
             | m.+1 => x <- read Task;; p ! x ;; rec m
             end) n).
End DependentProtocols.

Module Global.

  (* This attempt failed because of the impossibility of projecting
     behaviours to individual participants. This is because not all
     participants can observe the exchanged messages.
   *)
  Module FailedAttempt1.
    Import ITree.
    Inductive Global (A : Type) : Type := | Msg (p q : P).

    Inductive Prefix : Type -> Type :=
    | Last {A} : Global A -> Prefix A
    | And {A B} : Global A -> Prefix B -> Prefix (A * B).

    Definition gty := itree Prefix Set.

    CoFixpoint bottom {E} : itree E Set := go (Tau bottom).

    CoFixpoint pp p q :=
      go (Vis (Last (Msg (option nat) p q))
              (fun n =>
                 match n with
                 | Some x =>go (Vis (Last (Msg nat q p)) (fun _ => pp p q))
                 | None => go (Ret unit)
                 end)).

    (* I cannot project this *)
    CoFixpoint pipeline p q r :=
      go (Vis (And (Msg (option nat) p q) (Last (Msg bool q r)))
              (fun n =>
                 match n with
                 | (Some x, true) => pipeline p q r
                 | (None, false) => go (Ret unit)
                 | (_, _) => bottom
                 end)).

    (* I need the continuation to depend on the *observations* of each participant.
       E.g. p 'observes' [option nat]
       q 'observes' [option nat] and [bool]
       r 'observes' [bool]
       Maybe the global types should encode the projections themselves??
     *)
  End FailedAttempt1.

  Module Attempt2.
  (* Vis [:: Msg p q (option nat); Msg q r bool] *)
  (*     (fun pk => *)
  (*        match pk with *)
  (*        | Some n => Vis [:: ; ... ] *)
  (*        | None => Vis [Msg q r bool] *)
  (*                      fun k => *)
  (*                        match k with *)
  (*                        |  *)
  (*     ) *)

  (*     E (P -> Type) *)
  (*     fun k => *)
  (*       match k p with *)
  (*       | p1 => G1 *)
  (*       | ... *)
  (*       | pn => Gn *)
  (*       end *)

  End Attempt2.

End Global.

Extract Constant leq => "(<=)".
Extraction Inline leq.
Recursive Extraction Examples.prog31.
Recursive Extraction PingPong.some_client.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Structure.BiCCC.
Require Export Category.Functor.Structure.Cartesian.
Require Export Category.Functor.Structure.Cartesian.Closed.
Require Export Category.Functor.Structure.Terminal.
Require Export Category.Instance.Coq.
Require Export Category.Instance.AST.
Require Export Category.Tools.Represented.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section Abstraction.

Definition rel `{Repr a} `{Repr b}
(lam : a -> b) (ccc : repr a ~{AST}~> repr b) : Type :=
∀ x : a, convert (lam x) ≈ ccc ∘ convert x.

Definition rel2 `{Repr a} `{Repr b} `{Repr c}
(lam : a -> b -> c) (ccc : repr a ~{AST}~> repr c ^ repr b) : Type :=
∀ (x : a) (y : b), convert (lam x y) ≈ uncurry ccc ∘ convert (x, y).

Infix ">==>" := rel (at level 99) : category_scope.
Infix ">===>" := rel2 (at level 99) : category_scope.

Corollary ccc_id : ∀ `{Repr a}, (λ x : a, x) >==> id.
Proof. hammer_hook "Abstraction" "Abstraction.ccc_id". unfold rel; intros; cat. Qed.

Tactic Notation "step" constr(x) "=>" constr(y) :=
replace x with y by auto.

Corollary convert_fork `{Repr a} `{Repr b} (x : a) (y : b) :
convert x △ convert y ≈ convert (x, y).
Proof. hammer_hook "Abstraction" "Abstraction.convert_fork". reflexivity. Qed.

Theorem ccc_apply :
∀ `{Repr a} `{Repr b} `{Repr c}
(U : a -> b -> c) (U' : repr a ~{AST}~> repr c ^ repr b)
(V : a -> b) (V' : repr a ~{AST}~> repr b),
U >===> U' ->
V >==> V' ->
(λ x, U x (V x)) >==> eval ∘ U' △ V'.
Proof. hammer_hook "Abstraction" "Abstraction.ccc_apply".
unfold rel, rel2; repeat intros.
rewrite <- comp_assoc.
rewrite <- fork_comp.
rewrites.
rewrite <- eval_first.
comp_left.
unfold first.
rewrite <- fork_comp.
rewrite <- comp_assoc.
rewrite <- convert_fork; cat.
Qed.

Theorem ccc_apply_pair :
∀ `{Repr a} `{Repr b} `{Repr c}
(U : a * b -> c) (U' : repr a × repr b ~{AST}~> repr c)
(V : a -> b) (V' : repr a ~{AST}~> repr b),
U >==> U' ->
V >==> V' ->
(λ x, U (x, V x)) >==> U' ∘ id △ V'.
Proof. hammer_hook "Abstraction" "Abstraction.ccc_apply_pair".
unfold rel; intros ??????? U' V; subst; intros.
rewrite <- comp_assoc.
rewrite <- fork_comp.
rewrite id_left.
rewrites.
rewrite convert_fork.
reflexivity.
Qed.

Theorem ccc_curry :
∀ `{Repr a} `{Repr b} `{Repr c}
(U : a * b -> c) (U' : repr a × repr b ~> repr c),
U >==> U' ->
(λ x, λ y, U (x, y)) >===> curry U'.
Proof. hammer_hook "Abstraction" "Abstraction.ccc_curry".
unfold rel, rel2; repeat intros.
rewrite uncurry_curry.
apply X.
Qed.

Theorem ccc_terminal : ∀ `{Repr a},
(λ _ : a, tt) >==> to fobj_one_iso ∘ @one _ _ (repr a).
Proof. hammer_hook "Abstraction" "Abstraction.ccc_terminal".
unfold rel; simpl; intros; cat.
Qed.

Lemma distribute_forall : ∀ a {X} P, (a → ∀ (x : X), P x) → (∀ x, a → P x).
Proof. hammer_hook "Abstraction" "Abstraction.distribute_forall".
intros.
apply X0.
assumption.
Qed.

Lemma forall_distribute : ∀ a {X} P, (∀ x, a → P x) → (a → ∀ (x : X), P x).
Proof. hammer_hook "Abstraction" "Abstraction.forall_distribute".
intros.
apply X0.
assumption.
Qed.

End Abstraction.

Class Numerical (C : Category) `{@Cartesian C} := {
numerical_obj : obj;
add : numerical_obj × numerical_obj ~> numerical_obj
}.

Section NumericalFunctor.

Context `{F : C ⟶ D}.
Context `{@Cartesian C}.
Context `{@Numerical C _}.
Context `{@Cartesian D}.
Context `{@Numerical D _}.
Context `{@CartesianFunctor _ _ F _ _}.

Class NumericalFunctor := {
map_num : numerical_obj ≅ F numerical_obj;

fmap_add :
fmap add ≈ map_num ∘ @add D _ _ ∘ split (map_num⁻¹) (map_num⁻¹)
∘ @prod_out _ _ F _ _ _ numerical_obj numerical_obj
}.

End NumericalFunctor.

Instance Coq_Numerical : @Numerical Coq Coq_Cartesian := {
numerical_obj := nat;
add := prod_curry Nat.add
}.

Section Example.

Infix ">==>" := rel (at level 99) : category_scope.

End Example.


(** * Kildall: Forward Dataflow Analysis *)

(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** * Acknowledgements *)
(**
  This file is heavily based on:

      - lib/Lattice.v

      - backend/Kildall.v

  from the CompCert development,  modified to remove dependencies and
  optimizations.

*)

Require Import Equalities Orders.
Require Import FSets FMaps.

From Vellvm Require Import
     Analysis.Iteration
     Utils.Util
     Analysis.Dom.

Module FMapProps (E:UsualDecidableType) (M:FMapInterface.WSfun E).

  #[local] Notation K := M.key.

  Section FMapProps.

  Variable V : Type.

  Definition find_default (m:M.t V) (k:K) (d:V) : V :=
    match M.find k m with
      | None => d
      | Some m => m
    end.

  Lemma find_default_neq : forall  m n1 n2 l d,
    n1 <> n2 ->
    find_default (M.add n1 l m) n2 d = find_default m n2 d.
  Proof.
    intros. unfold find_default.
    destruct (M.find n2 (M.add _ _ _)) eqn:Heq1, (M.find n2 m) eqn:Heq2.
    apply M.find_2 in Heq1. apply M.add_3 in Heq1; auto. apply M.find_1 in Heq1.
      rewrite Heq2 in Heq1. injection Heq1. auto.
    apply M.find_2 in Heq1. apply M.add_3 in Heq1; auto. apply M.find_1 in Heq1.
      rewrite Heq2 in Heq1. discriminate Heq1.
    apply M.find_2 in Heq2. eapply M.add_2 in Heq2; eauto. apply M.find_1 in Heq2.
      rewrite Heq2 in Heq1. discriminate Heq1.
    trivial.
  Qed.

  Lemma find_default_eq : forall m n1 n2 l d,
    n1 = n2 ->
    find_default (M.add n1 l m) n2 d = l.
  Proof.
    unfold find_default; intros.
    erewrite M.find_1. reflexivity. apply M.add_1; auto.
  Qed.

  End FMapProps.

End FMapProps.

Module Type FORWARD_SOLVER.

  Declare Module L : LATTICE.             (* domain of approximations *)
  Declare Module N : UsualDecidableType.  (* program points *)

  Declare Module NM : FMapInterface.WSfun N.
  Module FMP := FMapProps N NM.

  Include EqLeNotation L.
  Notation "a !! b" := (FMP.find_default _ a b L.bot)
                         (at level 1, format "a !! b").
  Notation nlmap := (NM.t L.t).

  Parameter fixpoint: forall
    (succs: N.t -> list N.t)
    (trans: N.t -> L.t -> L.t)
    (inits: nlmap),
    option nlmap.

  Axiom fixpoint_solution : forall
      (succs: N.t -> list N.t)
      (trans: N.t -> L.t -> L.t)
      (inits: nlmap) res (n: N.t) (s: N.t),
    fixpoint succs trans inits = Some res ->
    NM.In n inits ->
    In s (succs n) ->
    trans n res!!n <= res!!s.

  Axiom fixpoint_entry : forall succs trans inits res n,
    fixpoint succs trans inits = Some res ->
    inits!!n <= res!!n.

  Axiom fixpoint_invariant : forall succs trans inits
    (P: N.t -> L.t -> Prop)
    (Pinits: forall n, P n inits!!n)
    (Ptrans: forall n ln s ls,
      In s (succs n) ->
      P n ln -> P s ls -> P s (L.join ls (trans n ln))),
    forall res n, fixpoint succs trans inits = Some res -> P n res!!n.

End FORWARD_SOLVER.

Module ForwardSolver (PC:UsualDecidableType) (LAT:LATTICE)<:
                     FORWARD_SOLVER with Module L := LAT
                                    with Module N := PC.

  Module L := LAT.
  Module N := PC.

  Include EqLeNotation L.

  (* TODO: can define a total order for PCs to use more efficient sets/maps *)
  Module NM := FMapWeakList.Make N.
  Module Import FMP := FMapProps N NM.
  Module NMFacts := FMapFacts.WFacts NM.

  Include EqLeNotation L.
  Notation "a !! b" := (find_default _ a b L.bot) (at level 1, format "a !! b").
  Notation nlmap := (NM.t L.t).

  Record state := mkst { lmap: NM.t L.t; wlist: list N.t }.

  Section KILDALL.

  Variable succs : N.t -> list N.t.
  Variable trans : N.t -> L.t -> L.t.
  Variable inits : nlmap.

  Definition prop_succ (out:L.t) (s:state) (n:N.t) : state :=
    let oldl := s.(lmap)!!n in
    let newl := L.join oldl out in
    if L.eq_dec oldl newl
    then s else mkst (NM.add n newl s.(lmap)) (n::s.(wlist)).

  Definition step (s:state) : NM.t L.t + state :=
    match s.(wlist) with
      | nil => inl s.(lmap)
      | n::rem =>
        inr (fold_left (prop_succ (trans n s.(lmap)!!n))
                       (succs n) (mkst s.(lmap) rem))
    end.

  Definition make_init_state : state :=
    mkst inits (map (@fst _ _) (NM.elements inits)).

  Definition fixpoint := Iter.iterate step make_init_state.

  (* correctness *)

  Definition n_invar (s:state) (n:N.t) : Prop :=
    In n s.(wlist) \/ forall m, In m (succs n) ->
      trans n s.(lmap)!!n <= s.(lmap)!!m.

  Definition state_invar (s:state) : Prop :=
    forall n, NM.In n inits -> n_invar s n.

  Lemma prop_n_invar_pres : forall o s n n',
    n_invar s n -> n_invar (prop_succ o s n') n.
  Proof.
    unfold n_invar. intros.
    set (s' := prop_succ o s n'); unfold prop_succ in s'.
    destruct (L.eq_dec _ _). apply H.
    destruct H. simpl; intuition.
      destruct (N.eq_dec n n').
        simpl; intuition. right. intros.
        destruct (N.eq_dec n' m); subst s'; simpl.
          rewrite find_default_neq, find_default_eq; auto.
            transitivity (lmap s)!!m. apply H; auto.
            subst n'; apply L.le_join_l.
          rewrite find_default_neq, find_default_neq; auto.
  Qed.

  (* TO MOVE *)
  Lemma fold_left_1 : forall {A B: Type} (P:A -> Prop) (f:A -> B -> A) (bs : list B)
                         (Hpres : forall a b, In b bs -> P a -> P (f a b)),
      forall a a',
        a' = fold_left f bs a -> P a -> P a'.
  Proof.
    intros. subst a'. generalize dependent a.
    induction bs; simpl; intros. assumption.
    apply IHbs. intros. apply Hpres. right; auto. assumption.
    apply Hpres. left; auto. assumption.
  Qed.

  (* TO MOVE *)
  Lemma fold_left_2 : forall {A B: Type} (P:A -> B -> Prop)
                        (f:A -> B -> A)
                        (Hpres : forall a b b', P a b -> P (f a b') b)
                        (Hintr : forall a b, P (f a b) b),
      forall a a' bs b,
        a' = fold_left f bs a ->
        In b bs -> P a' b.
  Proof.
    intros. subst a'. generalize dependent a.
    induction bs as [|b']. contradiction.
    simpl; intros. destruct H0. subst b'.
    set (a' := fold_left _ _ _). pattern a'.
    eapply fold_left_1; eauto.
    subst; reflexivity.
    apply IHbs; assumption.
  Qed.

  Lemma prop_n_out : forall o ns s s' n,
    s' = fold_left (prop_succ o) ns s ->
    ~ In n (wlist s') ->
    trans n (lmap s')!!n == trans n (lmap s)!!n.
  Proof.
    intros o ns s s' n Heqs'. pattern s'.
    eapply fold_left_1; eauto.
    intros. set (r := prop_succ o a b) in *.
    unfold prop_succ in r. destruct (L.eq_dec _ _). apply H0; auto.
    destruct (N.eq_dec b n). contradict H1; simpl; auto.
      subst r. simpl in *. rewrite find_default_neq; auto.
   intro. reflexivity.
  Qed.

  Lemma step_state_invar : forall s s',
    state_invar s -> inr s' = step s -> state_invar s'.
  Proof.
    unfold step, state_invar; intros s s' Hinv Hstep.
    destruct (wlist s) eqn:Hwls. discriminate Hstep.
    injection Hstep; clear Hstep. intros Heqs' n.

    destruct (N.eq_dec t n).

    (* n_invar is restablished for n *)
    subst t. unfold n_invar.
    destruct(in_dec N.eq_dec n (wlist s')) as [|Hwl]; [auto | right].
    intros m Hin. rewrite prop_n_out; eauto; simpl.
    generalize Hwl; clear Hwl. pattern s', m.

    eapply fold_left_2; eauto.
      intros a b b'.
      set (r := prop_succ _ a b').
      intros. unfold prop_succ in r. destruct (L.eq_dec _ _). apply H0; auto.
      unfold r. simpl. destruct (N.eq_dec b' b).
        rewrite find_default_eq; auto. apply L.le_join_r.
        rewrite find_default_neq; auto. apply H0. contradict Hwl; simpl; auto.

      intros a b.
      set (r := prop_succ _ a b).
      intros. unfold prop_succ in r. destruct (L.eq_dec _ _) as [Heq|].
      subst r. rewrite Heq. apply L.le_join_r.
      simpl. rewrite find_default_eq; auto. apply L.le_join_r.

    (* n_invar is preserved for all successors ~= n *)
    intros Hin. pattern s'. eapply fold_left_1; eauto.
    intros. apply prop_n_invar_pres. assumption.
    unfold state_invar, n_invar in Hinv |- *.
    simpl. specialize (Hinv n). rewrite Hwls in Hinv. destruct Hinv.
    assumption. left. destruct H; intuition. right. apply H.
  Qed.

  Lemma fixpoint_solution: forall res n s,
    fixpoint = Some res ->
    NM.In n inits ->
    In s (succs n) ->
    trans n res!!n <= res!!s.
  Proof.
    unfold fixpoint; intros. pattern res.
    eapply Iter.iter_prop with
      (step:=step) (P:=state_invar) (a:=make_init_state); eauto.
    intros a Ha.
    unfold step. destruct (wlist a) eqn:Heql.
    specialize (Ha n). destruct Ha.
      auto. rewrite Heql in *. contradiction. auto.

    eapply step_state_invar. apply Ha.
    unfold step. rewrite Heql. auto.

    left. simpl. apply in_map_iff.
    pose proof (NMFacts.elements_in_iff inits n0) as [He _].
    specialize (He H2). destruct He as [e Hine].
    apply InA_alt in Hine as [y [Heq Hk]].
    inversion Heq; eauto.
  Qed.

  (* monotonicity *)

  Definition le_nlmap (nl1 nl2: nlmap) : Prop :=
    forall n, nl1!!n <= nl2!!n.

  Lemma le_nlmap_refl : forall nl, le_nlmap nl nl.
  Proof.
    unfold le_nlmap. reflexivity.
  Qed.

  Instance le_nlmap_trans : Transitive le_nlmap.
    unfold Transitive, le_nlmap; intros. transitivity y !! n; auto.
  Qed.

  Hint Resolve L.le_join_l L.le_join_r : core .
    (* L.eq_equiv L.le_preorder L.le_poset L.eq_le_reflexive. *)
    (* Saw this in Relation_Definitions but it doesn't appear to work? *)

  Lemma prop_succ_le_nlmap: forall st out n,
    le_nlmap st.(lmap) (prop_succ out st n).(lmap).
  Proof.
    unfold le_nlmap, prop_succ; intros.
    destruct (L.eq_dec _ _). reflexivity.
    simpl. destruct (N.eq_dec n n0).
      subst. rewrite find_default_eq; auto.
      rewrite find_default_neq; auto. reflexivity.
  Qed.

  Lemma step_le_nlmap: forall st st',
    inr st' = step st ->
    le_nlmap st.(lmap) st'.(lmap).
  Proof.
    unfold step; intros. destruct (wlist st).
    discriminate. injection H. intro Heqs.
    pattern st'. eapply fold_left_1.
    intros. transitivity (lmap a).
      assumption. apply prop_succ_le_nlmap.
    apply Heqs. apply le_nlmap_refl.
  Qed.

  Lemma fixpoint_entry : forall res n,
    fixpoint = Some res -> inits!!n <= res!!n.
  Proof.
    unfold fixpoint. intros. pattern res.
    eapply Iter.iter_prop with (step:=step). intros.
    destruct (step a) eqn:Hstep.
    unfold step in Hstep. destruct (wlist a); try discriminate.
    injection Hstep. intro; subst t. apply H0.
    simpl in *. transitivity (lmap a)!!n. auto.
    apply step_le_nlmap. auto.
    change inits with (lmap make_init_state).
    cbv beta. reflexivity. apply H.
  Qed.

  Lemma fixpoint_invariant : forall
    (P: N.t -> L.t -> Prop)
    (Pinits: forall n, P n inits!!n)
    (Ptrans: forall n ln s ls,
      In s (succs n) ->
      P n ln -> P s ls -> P s (L.join ls (trans n ln))),
    forall res n, fixpoint = Some res -> P n res!!n.
  Proof.
    intros until 2.
    unfold fixpoint. intros. pattern res.
    eapply Iter.iter_prop with (step:=step); eauto.

    intro. destruct (step a) eqn:Hstep.

    (* last step  Q implies P *)
    unfold step in Hstep. destruct (wlist a); try discriminate.
    instantiate (1:=fun s => forall n, P n s.(lmap)!!n).
    injection Hstep. intro; subst t. intros; auto.

    (* P preserved across step *)
    simpl. intros. unfold step in Hstep.
    destruct (wlist a); try discriminate.
    injection Hstep; clear Hstep; intro Heqs.

    pattern s. eapply fold_left_1 with (f:=prop_succ _); eauto.
    intros. unfold prop_succ.
    destruct (L.eq_dec _ _); simpl; auto.
    destruct (N.eq_dec b n0).
    rewrite find_default_eq; auto.
      subst b. apply Ptrans; auto.
    rewrite find_default_neq; auto.
    auto.
  Qed.

  End KILDALL.

End ForwardSolver.


(** @Name Formalization of class diagrams
    @version 1.1
    @domains
    @authors Feng sheng
    @date 30/03/2019
    @description class and object diagrams (Coq v8.9)
**)

Require Import List.
Require Import String.
Require Import ListSet.
Require Import Arith.
Require Import Peano_dec.
Require Import Coq.Sorting.Mergesort.
Require Import Coq.Lists.List.

Import ListNotations.

Open Scope list_scope.
Open Scope string_scope.

(** ##### the structute of metamodel of class diagram #### **)

Definition class := string.

(* attribute  *)
Inductive ptype :=
| TClass : class -> ptype
| TInteger : ptype
| TBoolean : ptype
| TString : ptype.

Inductive attribute : Set :=
| BAttribute : string ->  class -> ptype -> attribute.

(** ----- operation(opid, opname, [parameter], classid) ----- **)
Inductive operation : Set :=
| BOperation : string  -> class -> list ptype -> operation.

(* ----- association(associd, classAid, classBid, assoctype) ----- *)
Definition assoc := string.

Inductive assoctype : Set :=
| bidirect : assoctype
| direct : assoctype
| aggregate : assoctype
| composite : assoctype.

Inductive associates : Set :=
| BAssoc: assoc -> list class -> assoctype -> associates.

(* ----- rolename(roleid, nameA, nameB, associd) ----- *)
Inductive role : Set :=
| BRole: assoc -> list string -> role.

(* ----- multiplicity(multid, classid, lower, upper, associd) ----- *)
Inductive natural :=
| Nat : nat -> natural
| Star : natural.

Inductive multiplicity : Set :=
| BMulti : assoc -> list (natural * natural) -> multiplicity.

(* ----- generalization(genid, superid, subid) ----- *)
Inductive generalization : Set :=
| BGen : class -> class -> generalization.

(** ------------------------------- **)
(** -------- Source Model --------- **)
Record SimpleUML : Set :=
  mkSimpleUML {
      mclass : list class;
      mattribute : list attribute;
      moperation : list operation;
      massoc : list assoc;
      massociates : list associates;
      mrolename : list role;
      mmultiplicity : list multiplicity;
      mgeneralization : list generalization
    }.

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

(* ----- projection of attribute ----- *)
Definition attr_name (a : attribute) : string :=
  match a with
  | (BAttribute n _ _) => n
  end.

Definition attr_class (a : attribute) : class :=
  match a with
  | (BAttribute _ c _) => c
  end.

Definition attr_type (a : attribute) : ptype :=
  match a with
  | (BAttribute _ _ t) => t
  end.

(* ----- projection of operation ----- *)
Definition op_name (o : operation) : string :=
  match o with
  | BOperation n _ _ => n
  end.

Definition op_class (o : operation) : class :=
  match o with
  | BOperation _ c _ => c
  end.

Definition op_parameters (o : operation) : list ptype :=
  match o with
  | BOperation _ _ l => l
  end.

(* ----- projection of association ----- *)
Print associates.

Definition assoc_name (a : associates) : assoc :=
  match a with
  | BAssoc n _ _ => n
  end.

Definition assoc_classes (a : associates) : list class :=
  match a with
  | BAssoc _ s _  => s
  end.

Definition assoc_type (a : associates) : assoctype :=
  match a with
  | BAssoc _ _ t => t
  end.

(* ----- projection of rolename ----- *)
Definition role_assoc (r : role) : assoc :=
  match r with
  | BRole a _ => a
  end.

Definition role_names (r : role) : list string :=
  match r with
  | BRole _ s => s
  end.

(* ----- projection of multiplicity ----- *)
Definition multi_assoc (r : multiplicity) : assoc :=
  match r with
  | BMulti a _ => a
  end.

Definition multi_naturals (r : multiplicity) :=
  match r with
  |  BMulti _ l => l
  end.

(* ----- projection of generalization ----- *)
Definition gener_sub (r : generalization) : class :=
  match r with
  |  BGen sub _ => sub
  end.

Definition gener_super (r : generalization) : class :=
  match r with
  |  BGen _ super => super
  end.

(* --------- the set of each concept--------- *)

Definition classes (model : SimpleUML) :=
  mclass model.

Definition attributes (model : SimpleUML) :=
  mattribute model.

Definition operations (model : SimpleUML) :=
  moperation model.

Definition assocs (model : SimpleUML) :=
  massoc model.

Definition associatess (model : SimpleUML) :=
  massociates model.

Definition roles (model : SimpleUML) :=
  mrolename model.

Definition multiplicities (model : SimpleUML) :=
  mmultiplicity model.

Definition generalizations (model : SimpleUML) :=
  mgeneralization model.

(* ----- Equality Judgement ----- *)
Definition eqclass_dec :
  forall x y: class, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beq_class x y :=
  if eqclass_dec x y then true else false.

Definition eqassoc_dec :
  forall x y: assoc, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beq_assoc c c' :=
  match eqassoc_dec c c' with
  | left _ => true
  | right _ => false
  end.

Definition eqmultiplicity_dec :
  forall x y: multiplicity, {x = y} + {x <> y}.
  repeat decide equality.
Defined.

Definition beq_multiplicity c c' :=
  match eqmultiplicity_dec c c' with
  | left _ => true
  | right _ => false
  end.

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

Fixpoint participating (c : class) (l: list associates) :=
  match l with
  | [] => []
  | h :: l' =>
    if 0 <? List.count_occ eqclass_dec  (assoc_classes h) c
    then (assoc_name h) :: participating c l' else participating c l'
  end.

Fixpoint navends_aux (a : assoc) (l : list role) :=
  match l with
  | [] => []
  | h :: l' =>
    if beq_assoc (role_assoc h) a
    then role_names h else navends_aux a l'
  end.

Fixpoint get_assoc (a : assoc) (l : list associates) :=
  match l with
  | [] => []
  | m  :: l =>
    if beq_assoc a (assoc_name m)
    then m :: get_assoc a l
    else get_assoc a l
  end.

Fixpoint navends' (l : list (class * string)) (c : class) :=
match l with
| [] => []
| (c', r) :: l' =>
  if beq_class c' c
  then navends' l' c else r :: navends' l' c
end.

Definition navends (c : class) (a : associates) (l : list role):=
  navends' (combine (assoc_classes a) (navends_aux (assoc_name a) l)) c.

Fixpoint nav (c : class) (la: list associates) (lr : list role) : list (list string) :=
  match la with
  | [] => []
  | h :: l' =>
    if 0 <? List.count_occ eqclass_dec  (assoc_classes h) c
    then (navends c h lr) :: nav c l' lr else nav c l' lr
  end.

Print nav.

Definition navs (c : class) (la: list associates) (lr : list role) :=
  fold_left (@app string) (nav c la lr) [].

(** --- get all parents --- **)

(** remove the duplicate class **)
Fixpoint deduplicate (ls : list class) :=
  match ls with
  | [] => []
  | x :: [] => [x]
  | x :: xs
    => if leb (count_occ eqclass_dec ls x) 1
       then x :: deduplicate xs
       else deduplicate xs
  end.

Fixpoint parents' (l : list generalization) (c : class) :=
match l with
| [] => []
| (BGen c' p) :: l' => if beq_class c c'
                       then [p]
                       else parents' l' c
end.

Definition parents_step (l : list generalization) (cs : list class) :=
  deduplicate (cs ++ List.flat_map (parents' l) cs).

Fixpoint all_parents' (l : list generalization) (cs : list class) (fuel : nat) :=
  match fuel with
  | 0 => cs
  | S fuel'
    => all_parents' l (parents_step l cs) fuel'
  end.

Definition parents (l : list generalization) (c : class) :=
  deduplicate (all_parents' l (parents' l c) (List.length l)).

(** ----- children ----- **)
Fixpoint children (l : list generalization) (c : class) :=
match l with
| [] => []
| (BGen p c') :: l' =>
  if beq_class c' c then [p] else children l' c
end.

Definition children_step (l : list generalization) (cs : list class) :=
  deduplicate (cs ++ List.flat_map (children l) cs).

Fixpoint all_children (l : list generalization) (cs : list class) (fuel : nat) :=
  match fuel with
  | 0 => cs
  | S fuel' => all_children l (children_step l cs) fuel'
  end.

Definition get_children (l : list generalization) (c : class) :=
  deduplicate (all_children l (children l c) (List.length l)).

(* ----- get all attributes ----- *)
Fixpoint get_attributes (c : class) (attrs : list attribute) :=
  match attrs with
  | [] => []
  | a :: attr' => if beq_class c (attr_class a)
                   then a :: get_attributes c attr'
                   else get_attributes c attr'
  end.

Fixpoint get_multiplicities (a : assoc) (ml : list multiplicity) :=
  match ml with
  | [] => []
  | m  :: l =>
    if beq_assoc a (multi_assoc m)
    then m :: get_multiplicities a l
    else get_multiplicities a l
  end.

Check get_multiplicities.

(** ###### Structural Constraints ##### **)
Definition unique_class (model : SimpleUML) : Prop :=
  NoDup (classes model).

Definition unique_attribute (model : SimpleUML) : Prop :=
  NoDup (attributes model).

Definition unique_attr_names (model : SimpleUML) : Prop :=
  NoDup (map attr_name (attributes model)).

(** ##### Non-structural Contraints ##### **)

Definition nsc_attribute_unique (model : SimpleUML) : Prop :=
  forall o : class,
    In o (classes model) ->
    NoDup (map attr_name (get_attributes o (attributes model))).

Definition nsc_nselfgen (model : SimpleUML) :=
  forall c : class, In c (classes model) ->
    ~ In c (get_children (generalizations model) c).

Print nav.

Definition nsc_role (model : SimpleUML) :=
  forall c : class, In c (classes model) ->
    let l := app (parents (generalizations model) c) [c] in
    forall c1 c2, In c1 l /\ In c2 l -> beq_class c1 c2 = false ->
       forall r, In r (navs c1 (associatess model) (roles model)) ->
          ~ In r (navs c2 (associatess model) (roles model)).

Definition natural_eq_n (m : natural) (n : nat) :=
  match m with
  | Nat m' => beq_nat m' n
  | Star => false
  end.

Definition multi_lower_eq_n (m : multiplicity) (n : nat) :=
  match hd_error (multi_naturals m) with
  | Some (lower, upper) => Some (natural_eq_n lower n)
  | None => None
  end.

Definition multi_upper_eq_n (m : multiplicity) (n : nat) :=
  match hd_error (multi_naturals m) with
  | Some (lower, upper) => Some (natural_eq_n upper n)
  | None => None
  end.

Definition nsc_assoc (model : SimpleUML) :=
  forall a : associates,
    In a (associatess model) /\
    (assoc_type a = composite \/ assoc_type a = aggregate) ->
    forall m : multiplicity,
      In m (get_multiplicities (assoc_name a) (multiplicities model)) ->
      multi_lower_eq_n m 1 = Some true /\ multi_upper_eq_n m 1 = Some true.

Require Coq.extraction.Extraction.
Extraction Language OCaml.

(* Extraction "class.ml" nsc_assoc. *)