Require Export Structure.
Require Export Categories.Slice.

Program Definition SliceTop_mixin (C: Category) (x: C) := TopCategory.Mixin (C / x)
  {|
    Slice.dom := x;
    Slice.oarr := id x;
  |}
  (fun f => {|
    Slice.arr := Slice.oarr f;
  |})
  _.
Next Obligation.
  apply comp_id_l.
Qed.
Next Obligation.
  apply Slice.hom_eq; simpl.
  rewrite <- comp_id_l.
  symmetry.
  exact (Slice.comm f).
Qed.

Canonical SliceTop (C: Category) (x: C) := TopCategory.Pack (C / x) (SliceTop_mixin C x).

Program Definition SliceBot_mixin (C: BotCategory) (x: C) := BotCategory.Mixin (C / x)
  {|
    Slice.dom := 0;
    Slice.oarr := ¡;
  |}
  (fun f => {|
    Slice.arr := ¡;
  |})
  _.
Next Obligation.
  symmetry.
  apply from_zero_unique.
Qed.
Next Obligation.
  apply Slice.hom_eq; simpl.
  apply from_zero_unique.
Qed.

Canonical SliceBot (C: BotCategory) (x: C) := BotCategory.Pack (C / x) (SliceBot_mixin C x).

Program Definition SliceCoprod_mixin (C: CoprodCategory) (x: C) := CoprodCategory.Mixin (C / x)
  (fun f g => {|
    Slice.dom := Slice.dom f + Slice.dom g;
    Slice.oarr := [Slice.oarr f, Slice.oarr g];
  |})
  (fun f g h a b => {|
    Slice.arr := [Slice.arr a, Slice.arr b];
  |})
  (fun f g => {|
    Slice.arr := in1;
  |})
  (fun f g => {|
    Slice.arr := in2;
  |})
  _.
Next Obligation.
  rewrite merge_comp.
  f_equal; apply Slice.comm.
Qed.
Next Obligation.
  apply merge_in1.
Qed.
Next Obligation.
  apply merge_in2.
Qed.
Next Obligation.
  setoid_rewrite Slice.hom_eq; simpl.
  apply merge_in.
Qed.

Canonical SliceCoprod (C: CoprodCategory) (x: C) := CoprodCategory.Pack (C / x) (SliceCoprod_mixin C x).


Require Import VST.floyd.proofauto.
Require Import triang.
Require Import spec_stdlib.
Require Import spec_pile.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Fixpoint triang (n: nat) :=
 match n with
 | O => 0
 | S n' => Z.of_nat n + triang n'
 end.

Definition Triang_nth_spec :=
 DECLARE _Triang_nth
 WITH n:Z, gv: globals
 PRE [ _n OF tint ]
    PROP( 0 <= n < 1000)
    LOCAL(temp _n (Vint (Int.repr n)); gvars gv)
    SEP(mem_mgr gv)
 POST[ tint ]
    PROP()
    LOCAL(temp ret_temp (Vint (Int.repr (triang (Z.to_nat n)))))
    SEP(mem_mgr gv).

Definition specs := [Triang_nth_spec].


From Cat Require Import Cat.

Set Implicit Arguments.

Class isEqualizer
  (C : Cat) {A B : Ob C} (f g : Hom A B)
  (E : Ob C) (equalize : Hom E A)
  (factorize : forall {E' : Ob C} (e' : Hom E' A), e' .> f == e' .> g -> Hom E' E)
  : Prop :=
{
  ok : equalize .> f == equalize .> g;
  factorize_equalize :
    forall {E' : Ob C} (e' : Hom E' A) (H : e' .> f == e' .> g),
      factorize e' H .> equalize == e';
  equiv_equalizer :
    forall {E' : Ob C} {e1 e2 : Hom E' E},
      e1 .> equalize == e2 .> equalize -> e1 == e2;
}.

#[export] Hint Mode isEqualizer ! ! ! ! ! ! ! ! : core.
#[export] Hint Mode isEqualizer ! ! ! - - - - - : core.

Section isEqualizer.

Context
  {C : Cat} {A B : Ob C} {f g : Hom A B}
  {E : Ob C} {equalize : Hom E A}
  {factorize : forall {E' : Ob C} (e' : Hom E' A), e' .> f == e' .> g -> Hom E' E}
  {isEq : isEqualizer C f g E equalize (@factorize)}.

Arguments factorize {E' e'} _.

Lemma equiv_equalizer' :
  forall {E' : Ob C} {e1 e2 : Hom E' E},
    e1 == e2 <-> e1 .> equalize == e2 .> equalize.
Proof.
  split.
  - now intros ->.
  - now apply equiv_equalizer.
Qed.

Lemma Proper_factorize :
  forall {E' : Ob C} {e1 e2 : Hom E' A} (H1 : e1 .> f == e1 .> g) (H2 : e2 .> f == e2 .> g),
    e1 == e2 -> factorize H1 == factorize H2.
Proof.
  now intros; rewrite equiv_equalizer', !factorize_equalize.
Qed.

Lemma universal :
  forall
    [E' : Ob C] [e' : Hom E' A] (H : e' .> f == e' .> g)
    (h : Hom E' E),
      factorize H == h <-> h .> equalize == e'.
Proof.
  split.
  - now intros <-; rewrite factorize_equalize.
  - now intros Heq; rewrite equiv_equalizer', factorize_equalize.
Qed.

Lemma factorize_unique :
  forall
    [E' : Ob C] [e' : Hom E' A] (H : e' .> f == e' .> g)
    (h : Hom E' E),
      h .> equalize == e' -> h == factorize H.
Proof.
  now intros; rewrite equiv_equalizer', factorize_equalize.
Qed.

Lemma factorize_ok :
  factorize ok == id E.
Proof.
  now rewrite equiv_equalizer', factorize_equalize, comp_id_l.
Defined.

Lemma comp_factorize :
  forall {X Y : Ob C} {e1 : Hom X Y} {e2 : Hom Y A} (Heq : e2 .> f == e2 .> g),
    e1 .> factorize Heq == factorize (wut_l e1 Heq).
Proof.
  now intros; rewrite equiv_equalizer', factorize_equalize, comp_assoc, factorize_equalize.
Qed.

Lemma isMono_equalize :
  isMono equalize.
Proof.
  now intros X h1 h2 Heq; rewrite equiv_equalizer'.
Qed.

End isEqualizer.

Ltac equalizer_simpl :=
  repeat (rewrite
    ?comp_factorize, ?equiv_equalizer', ?factorize_equalize, ?factorize_ok,
    ?comp_id_l, ?comp_id_r, ?comp_assoc).

Section Traditional.

Context
  [C : Cat]
  [X Y : Ob C]
  [f g : Hom X Y].

Lemma isEqualizer_uiso :
  forall
    {E1 : Ob C} {equalize1 : Hom E1 X}
    {factorize1 : forall (E1' : Ob C) (e1' : Hom E1' X), e1' .> f == e1' .> g -> Hom E1' E1}
    {E2 : Ob C} {equalize2 : Hom E2 X}
    {factorize2 : forall (E2' : Ob C) (e2' : Hom E2' X), e2' .> f == e2' .> g -> Hom E2' E2},
      isEqualizer C f g E1 equalize1 factorize1 ->
      isEqualizer C f g E2 equalize2 factorize2 ->
        exists!! f : Hom E1 E2, isIso f /\ equalize1 == f .> equalize2.
Proof.
  intros * H1 H2.
  exists (factorize2 E1 equalize1 ok).
  repeat split.
  - exists (factorize1 E2 equalize2 ok).
    now rewrite !equiv_equalizer', !comp_assoc, !factorize_equalize, !comp_id_l.
  - now rewrite factorize_equalize.
  - now intros y [_ ?]; rewrite equiv_equalizer', factorize_equalize.
Qed.

Lemma isEqualizer_iso :
  forall
    {E1 : Ob C} {e1 : Hom E1 X}
    {factorize1 : forall (E1' : Ob C) (e1' : Hom E1' X), e1' .> f == e1' .> g -> Hom E1' E1}
    {E2 : Ob C} {e2 : Hom E2 X}
    {factorize2 : forall (E2' : Ob C) (e2' : Hom E2' X), e2' .> f == e2' .> g -> Hom E2' E2},
      isEqualizer C f g E1 e1 factorize1 ->
      isEqualizer C f g E2 e2 factorize2 ->
        E1 ~ E2.
Proof.
  now intros; destruct (isEqualizer_uiso H H0) as [i []]; exists i.
Qed.

Lemma isEqualizer_equiv_equalize :
  forall
    (E : Ob C) (equalize1 equalize2 : Hom E X)
    (factorize : forall (E' : Ob C) (e : Hom E' X), e .> f == e .> g -> Hom E' E),
      isEqualizer C f g E equalize1 factorize ->
      isEqualizer C f g E equalize2 factorize ->
        equalize1 == equalize2.
Proof.
  now intros; rewrite <- comp_id_l, <- factorize_ok, factorize_equalize.
Qed.

Lemma isEqualizer_equiv_factorize :
  forall
    (E : Ob C) (equalize : Hom E X)
    (factorize1 factorize2 :
      forall (E' : Ob C) (e' : Hom E' X), e' .> f == e' .> g -> Hom E' E),
      isEqualizer C f g E equalize factorize1 ->
      isEqualizer C f g E equalize factorize2 ->
        forall (E' : Ob C) (e' : Hom E' X) (H : e' .> f == e' .> g),
          factorize1 E' e' H == factorize2 E' e' H.
Proof.
  now intros; rewrite equiv_equalizer', !factorize_equalize.
Qed.

Lemma isIso_equalize :
  forall
    (E : Ob C) (equalize : Hom E X)
    (factorize : forall (E' : Ob C) (e' : Hom E' X), e' .> f == e' .> g -> Hom E' E),
      isEqualizer C f g E equalize factorize -> isEpi equalize -> isIso equalize.
Proof.
  intros * HisEq HisEpi; red.
  assert (Hfg : id X .> f == id X .> g) by (rewrite !comp_id_l; apply HisEpi, ok).
  exists (factorize _ (id X) Hfg).
  now rewrite equiv_equalizer', comp_assoc, factorize_equalize, comp_id_l, comp_id_r.
Qed.

End Traditional.

Class HasEqualizers (C : Cat) : Type :=
{
  equalizer :
    forall {X Y : Ob C}, Hom X Y -> Hom X Y -> Ob C;
  equalize :
    forall {X Y : Ob C} (f g : Hom X Y), Hom (equalizer f g) X;
  factorize :
    forall [X Y : Ob C] [f g : Hom X Y] [E' : Ob C] (e' : Hom E' X),
      e' .> f == e' .> g -> Hom E' (equalizer f g);
  isEqualizer_HasEqualizers :>
    forall {X Y : Ob C} (f g : Hom X Y),
      isEqualizer C f g (equalizer f g) (equalize f g) (@factorize _ _ f g)
}.

Arguments equalizer [C _ X Y] _ _.
Arguments equalize  [C _ X Y] _ _.
Arguments factorize [C _ X Y f g E'] _ _.


Module FeatureModelSemantics.
Require Export Coq.Lists.ListSet.
Require Export Coq.Lists.List.
Require Export Coq.Bool.Bool.
Require Export Coq.Classes.RelationClasses.
Require Export formulatheory_int.
Require Export formulatheory_def.
Import FormulaTheory.

  Definition wfFM_func (fm : FM) : Prop := (wfTree_func fm) /\
    (wfFormulae_func fm).

  Definition satImpConsts_func (fm : FM) (c : Configuration) : Prop :=
  forall n: Name, set_In n (c) -> set_In n (fst fm).

  Definition satExpConsts_func (fm : FM) (c : Configuration) : Prop :=
  forall f: Formula, set_In f (snd fm) -> (satisfies_func f c = True).

  Definition Is_truePB (b:Prop) : bool :=
    match b with
      | True => true
    end.

  Fixpoint filter_func (fm:FM) (s: set Configuration) : set Configuration :=
    match s with
    | nil => nil
    | a1 :: x1 =>
          if Is_truePB ((satImpConsts_func fm a1) /\
              (satExpConsts_func fm a1)) then a1 :: filter_func fm x1
           else filter_func fm x1
    end.

Fixpoint genConf_func (fm : set Name) : set Configuration :=
  match fm with
  | nil => nil
  | x :: xs => (set_add conf_dec_axiom (set_add name_dec_axiom x (nil)) (genConf_func xs)) ++ (genConf_func xs)
  end.

  Definition semantics_func (fm : FM) : set Configuration :=
    filter_func fm (genConf_func (ns_func fm)).

  Definition refines_func (abs : FM) (con : FM) : Prop :=
    if andb (Is_truePB (wfFM_func abs)) (Is_truePB(wfFM_func con)) then
      forall (conf : Configuration), set_In conf (semantics_func abs)
        -> set_In conf (semantics_func con)
          else False.

  Definition refines2_func (abs : FM) (con : FM) : Prop :=
    forall (conf1 : Configuration), set_In conf1 (semantics_func abs) ->
      exists (conf2 : Configuration),  set_In conf2 (semantics_func con).

  Definition nsf_func (fm : FM) : set Name := fst fm.

End FeatureModelSemantics.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Arith.PeanoNat.
Require Import Coq.Numbers.DecimalString.
Require Import Coq.NArith.NArith.
Require Import Coq.Strings.String.
Require Import Cava.Util.List. (* TODO: From cava 1 *)

Require Import Cava.Types.
Require Import Cava.Expr.
Require Import Cava.Semantics.

Local Open Scope N.

Section Var.
  Import ExprNotations.
  Import PrimitiveNotations.
  Context {var : tvar}.

  Definition fork2 {A} : Circuit [] [A] (A ** A) := {{
    fun a => (a, a)
  }}.

  Definition fib_init sz : denote_type (BitVec sz) := 2^(N.of_nat sz)-1.

  Definition fibonacci {sz: nat}: Circuit (BitVec sz ** BitVec sz) [] (BitVec sz) := {{
    let/delay r1 :=
      let r2 := delay r1 initially (fib_init sz) in
      r1 + r2
      initially (1: denote_type (BitVec sz)) in
    r1
  }}.
End Var.

Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import coqutil.Tactics.Tactics.
Require Import Cava.Util.List.
Require Import Cava.Util.Tactics.

Fixpoint fibonacci_nat (n : nat) :=
  match n with
  | 0 => 0
  | S m =>
    let f_m := fibonacci_nat m in
    match m with
    | 0 => 1
    | S p => fibonacci_nat p + f_m
    end
  end%nat.

Definition spec_of_fibonacci (sz : nat) (input : list unit) : list N
  := map (fun n => N.of_nat (fibonacci_nat n) mod (2 ^ N.of_nat sz))%N (seq 0 (List.length input)).

Lemma fork2_step A state input : step (fork2 (A:=A)) state (input, tt) = (tt, (input, input)).
Proof. reflexivity. Qed.

Lemma fibonacci_step sz state input :
  step (fibonacci (sz:=sz)) state input
  =
    let sum := (fst state + snd state) mod (2 ^ N.of_nat sz) in
    (sum, fst state, sum).
Proof.
  intros; cbn [step fibonacci Bv2N Vector.of_list Primitives.binary_semantics ].
  repeat (destruct_pair_let; cbn [split_absorbed_denotation combine_absorbed_denotation List.app absorb_any fst snd ]).
  reflexivity.
Qed.

Definition fibonacci_invariant {sz: nat}
           (t : nat) (loop_state : N * N)
           (output_accumulator : list (N)) : Prop :=
  let r1 := fst loop_state in
  let r2 := snd loop_state in
  (* at timestep t... *)
  (* ...r1 holds fibonacci_nat (t-1), or 1 if t=0 *)
  r1 = match t with
       | 0%nat => 1
       | S t_minus1 =>
         (N.of_nat (fibonacci_nat t_minus1) mod (2 ^ N.of_nat sz))
       end
  (* ... and r2 holds fibonacci_nat (t-2), or 1 if t=1, 2^sz-1 if t=0 *)
  /\ r2 = match t with
         | 0%nat => (2 ^ N.of_nat sz - 1)
         | 1%nat => 1
         | S (S t_minus2) => N.of_nat(fibonacci_nat t_minus2) mod (2 ^ N.of_nat sz)
         end
  (* ... and the output accumulator matches the circuit spec for the
     inputs so far *)
  /\ output_accumulator = spec_of_fibonacci sz (repeat tt t).

(* Helper lemma for fibonacci_correct *)
Lemma fibonacci_nat_step n :
  fibonacci_nat (S (S n)) = (fibonacci_nat (S n) + fibonacci_nat n)%nat.
Proof. cbn [fibonacci_nat]. lia. Qed.

Lemma fibonacci_correct sz input :
  simulate (fibonacci (sz:=sz)) input = spec_of_fibonacci sz input.
Proof.
  cbv [simulate simulate'].
  fold (fold_left_accumulate (step (fibonacci (sz:=sz))) input (reset_state fibonacci)).
  rewrite fold_left_accumulate_to_seq with (default:=tt).
  assert (2 ^ (N.of_nat sz) <> 0) by (apply N.pow_nonzero; lia).
  eapply fold_left_accumulate_invariant_seq with (I:=fibonacci_invariant (sz:=sz)).
  { cbv [fibonacci_invariant]. ssplit; reflexivity. }
  { cbv [fibonacci_invariant].
    intros; destruct_products; cbn [fst snd] in *; subst; cbn [fst snd].
    rewrite fibonacci_step. cbn [fst snd].
    repeat destruct_one_match.
    { (* t = 0 case *)
      rewrite N.sub_1_r, N.add_1_l, N.succ_pred; try apply H.
      rewrite N.mod_same, N.mod_0_l;
        ssplit; try reflexivity; try apply H.
      }
    { (* t = 1 case *)
      ssplit; reflexivity.
    }
    { (* t > 1 case *)
      rewrite N.add_mod_idemp_r, N.add_mod_idemp_l by lia.
      ssplit.
      { cbn [fibonacci_nat]. f_equal; lia. }
      { reflexivity. }
      { cbv [spec_of_fibonacci].
        autorewrite with push_length.
        rewrite seq_S with (len:=S (S _)).
        autorewrite with natsimpl. rewrite map_app.
        cbn [map]. rewrite fibonacci_nat_step.
        rewrite Nat2N.inj_add.
        reflexivity. } } }
  { cbv [fibonacci_invariant]. intros.
    logical_simplify; subst.
    autorewrite with push_length.
    erewrite <-list_unit_equiv. reflexivity. }
Qed.