(** smart constructors *)

Set Implicit Arguments.

Require Import
        String
        Syntax.Regex.

Open Scope string_scope.

(* choice *)

Fixpoint choice_smart (e e' : regex) : regex :=
  match e, e' with
  | #0, e2 => e2
  | e1, #0 => e1
  | e1, e2 => e1 :+: e2
  end.

Notation "e1 ':++:' e2" := (choice_smart e1 e2)(at level 40, left associativity).

Lemma choice_smart_sound : forall e1 e2 s, s <<- (e1 :++: e2) -> s <<- (e1 :+: e2).
Proof.
  induction e1 ; destruct e2 ; intros s H ; inverts* H ; auto.
Qed.

Lemma choice_smart_complete : forall e1 e2 s, s <<- (e1 :+: e2) -> s <<- (e1 :++: e2).
Proof.
  induction e1 ; destruct e2 ; simpl in * ;
    intros s H ; try inverts* H ; try inverts_in_regex.
Qed.

(* concatenation *)

Fixpoint cat_smart (e e' : regex) : regex :=
  match e, e' with
  | #0 , e2 => #0
  | #1 , e2 => e2
  | e1 , #0 => #0
  | e1 , #1 => e1
  | e1 , e2 => e1 @ e2
  end.

Notation "e1 ':@:' e2" := (cat_smart e1 e2)(at level 40, left associativity).

Lemma cat_smart_sound : forall e1 e2 s, s <<- (e1 :@: e2) -> s <<- (e1 @ e2).
Proof.
  induction e1 ; destruct e2 ; intros s H ; inverts* H ;
    try solve [econstructor ; eauto ; try rewrite* str_append_nil_end]
      || (try apply InCat with (s := String a (s0 ++ s'))(s' := "") ; eauto ;
         try rewrite* str_append_nil_end).
Qed.

Lemma cat_smart_complete : forall e1 e2 s, s <<- (e1 @ e2) -> s <<- (e1 :@: e2).
Proof.
  induction e1 ; destruct e2 ; simpl in * ;
    intros s H ; try inverts* H ;
      repeat (match goal with
           | [ H : _ <<- #0 |- _ ] =>
             inverts* H
           | [H : _ <<- #1 |- _] =>
             inverts* H
           | [|- context[_ ++ ""]] =>
             rewrite str_append_nil_end ; auto
           end).
Qed.

(* star *)

Fixpoint star_smart (e : regex) : regex :=
  match e with
  | #0 => #1
  | #1 => #1
  | e1 => e1 ^*
  end.

Notation "e ':^*:'" := (star_smart e)(at level 40, left associativity).

Lemma star_smart_sound : forall e s, s <<- (e :^*:) -> s <<- (e ^*).
Proof.
  induction e ; intros s H ; inverts* H.
Qed.

Lemma star_smart_complete : forall e s, s <<- (e ^*) -> s <<- (e :^*:).
Proof.
  intros e s H ; destruct e ; simpl in * ; inverts* H ;
    repeat (match goal with
            | [H : _ <<- #0 |- _] =>
              inverts* H
            | [H : _ <<- #1 |- _] =>
              inverts* H
            end).
Qed.


From CP Require Export operations.

Theorem TEqualAtomBCommutative: forall (a1 a2: atom), EqualAtomB a1 a2 = EqualAtomB a2 a1.
Proof. destruct a1, a2; try discriminate; try reflexivity. Qed.

Theorem TEqualAtomBagBCommutative: forall (b1 b2: bag atom), EqualAtomBagB b1 b2 = EqualAtomBagB b2 b1.
Proof. induction b1, b2; try discriminate; try reflexivity.
repeat (destruct a, a0; try discriminate; try reflexivity; try simpl; try rewrite IHb1; try reflexivity).
Qed.

Theorem TEqualNatCommutative: forall (n1 n2: nat), (n1 =? n2) = (n2 =? n1).
Proof. induction n1, n2; try reflexivity. simpl. rewrite IHn1. reflexivity. Qed.

Theorem TEqualStateBCommutative: forall (s1 s2: state), EqualStateB s1 s2 = EqualStateB s2 s1.
Proof. unfold EqualStateB. destruct s1, s2; destruct n, n0; try discriminate; try reflexivity. simpl.
rewrite <- TEqualNatCommutative. reflexivity. Qed.

(*
Theorem TEqualTermBCommutative: forall (t1 t2: g_term), EqualTermB t1 t2 = EqualTermB t2 t1.
Proof. Admitted.
*)
(*Informal proof: it is straightforward following the definition of EqualTermB*)

(*
Theorem TEqualTermBagBCommutative: forall (m1 m2: g_multiset), EqualTermBagB m1 m2 = EqualTermBagB m2 m1.
Proof. unfold EqualTermBagB. induction m1, m2; try reflexivity; try discriminate.
simpl. rewrite TEqualTermBCommutative. rewrite IHm1. reflexivity. Qed.
*)

(*
Theorem TEqualCPSystemConfBCommutative: forall (sys1 sys2: cPsystem_conf),
EqualCPSystemConfigurationB sys1 sys2 = EqualCPSystemConfigurationB sys2 sys1.
Proof. destruct sys1, sys2; try reflexivity; try discriminate. simpl. rewrite TEqualTermBagBCommutative.
rewrite TEqualStateBCommutative. reflexivity. Qed.
*)

Theorem TEqualAtomBReflexive: forall (a1: atom), EqualAtomB a1 a1 = true.
Proof. destruct a1; try reflexivity. Qed.

Theorem EqualAtomBagBReflexive: forall (b1: bag atom), EqualAtomBagB b1 b1 = true.
Proof. Proof. induction b1. reflexivity. unfold EqualAtomBagB. simpl. rewrite TEqualAtomBReflexive.
unfold EqualAtomBagB in IHb1. rewrite IHb1. reflexivity. Qed.

Theorem TEqualStateBReflexive: forall (s1: state), EqualStateB s1 s1 = true.
Proof. unfold EqualStateB. destruct s1; induction n; try discriminate; try reflexivity. simpl.
simpl in IHn. rewrite IHn; try reflexivity. Qed.

(*
Theorem TEqualTermBReflexive: forall (t1: g_term), EqualTermB t1 t1 = true.
Proof. destruct t1; try reflexivity. induction n1; try reflexivity. simpl. simpl in IHn1. rewrite IHn1. reflexivity.
destruct a1; try reflexivity. induction b1; try reflexivity. destruct label; try reflexivity. Admitted.
*)
(*Informal proof: Similar to TEqualTermBCommutative, it is straightforward following EqualTermB's definition*)

(*
Theorem EqualTermBagBReflexive: forall (m1: g_multiset), EqualTermBagB m1 m1 = true.
Proof. induction m1. compute. reflexivity. unfold EqualTermBagB. simpl. rewrite TEqualTermBReflexive.
simpl. unfold EqualTermBagB in IHm1. rewrite IHm1. reflexivity. Qed.
*)

(*
Theorem TEqualCPSystemConfBReflexive: forall (sys1: cPsystem_conf), EqualCPSystemConfigurationB sys1 sys1 = true.
Proof. destruct sys1; try reflexivity; try discriminate. simpl. rewrite TEqualStateBReflexive.
rewrite EqualTermBagBReflexive. reflexivity. Qed.
*)

Theorem TLessThanAtomBTransitive: forall (a1 a2 a3: atom), LessThanAtomB a1 a2 = true /\ LessThanAtomB a2 a3 = true ->
LessThanAtomB a1 a3 = true.
Proof. intros. destruct H. destruct a1, a2, a3; try reflexivity; try discriminate H; try discriminate H0. Qed.

Theorem TInequalCPSystemConfB1: forall (sys1 sys2: cPsystem_conf),
EqualStateB (SystemState sys1) (SystemState sys2) = false -> EqualCPSystemConfigurationB sys1 sys2 = false.
Proof. destruct sys1, sys2. destruct s1, s0. unfold SystemState. unfold EqualCPSystemConfigurationB.
unfold EqualStateB. intros. destruct n, n0; try discriminate; try reflexivity. simpl. simpl in H. rewrite H.
reflexivity. Qed.

Theorem TInequalCPSystemConfB2: forall (sys1 sys2: cPsystem_conf),
EqualTermBagB (SystemTerms sys1) (SystemTerms sys2) = false -> EqualCPSystemConfigurationB sys1 sys2 = false.
Proof. intros. destruct sys1, sys2. simpl. simpl in H. rewrite H. destruct s1, s0.
generalize dependent n0; try induction n; try reflexivity. destruct n0; try reflexivity.
destruct n0; try reflexivity. simpl. simpl in IHn. rewrite IHn. reflexivity. Qed.


(** * Coq: jak udowodnić, że nasz program działa poprawnie *)

(** Cześć, nazywam się Wojciech Kołowski i witam cię na Dniach Otwartych
    Instytutu Informatyki UWr 2021. Wszystkie materiały z tego wydarzenia
    możesz znaleźć
    #tutaj#,
    ja natomiast opowiem ci dziś o języku programowania Coq. *)

(** * Coq a inne języki programowania *)

(** Coq (wymawiane "kok"; nazwa pochodzi od francuskiego słowa _coq_,
    oznaczającego koguta) jest mocno wyjątkowym językiem programowania,
    różniącym się znacznie od większości popularnych języków, jak C++ czy
    Python.

    Coq jest przede wszystkim językiem funkcyjnym. Funkcje są podstawowym
    budulcem wszystkich programów i cieszą się niespotykaną w mainstreamowych
    językach elastycznością - mogą brać inne funkcje jako argumenty, zwracać
    funkcje jako wynik, i tak dalej. W Coqu (i w ogóle w językach funkcyjnych)
    większość rzeczy robimy inaczej, niż w innych językach programowania:
    - Zamiast zmiennych globalnych, dajemy funkcjom dodatkowe argumenty.
    - Zamiast iterować po strukturach danych zrobionych ze wskaźników,
      przemierzamy drzewa za pomocą funkcji rekurencyjnych (czyli takich,
      które wywołują same siebie).
    - Zamiast wielkich pętli przetwarzających dane, budujemy duże funkcje
      składając ze sobą wiele małych funkcji.
    - Różnic jest więcej, ale nie sposób wszystkich ich tutaj wymienić.

    Jednak jest coś jeszcze, co odróżnia Coqa nawet od pozostałych języków
    funkcyjnych. Mianowicie, Coq pozwala na formalną weryfikację poprawności
    napisanych w nim programów... ale co to właściwie znaczy? W zwykłych
    językach, jak Python czy C++, w zasadzie jedyną możliwością sprawdzenia,
    czy napisany przez nas program działa tak jak chcemy, są testy. Pojedynczy
    test uruchamia nasz program dla jakichś konkretnych danych wejściowych i
    sprawdza, czy wynik jest taki jak się spodziewamy. Jeżeli napiszemy dużo
    testów i wszystkie one kończą się pomyślnie, to uznajemy, że nasz program
    jest poprawny.

    Takie podejście jako tako sprawdza się w praktyce, ale nie daje pełnych i
    niepodważalnych gwarancji poprawności. Wszak, jak powiedział niegdyś klasyk
    informatyki, "testy mogą wykazać obecność błędów w programie, ale nie mogą
    wykazać ich nieobecności". Coq zaś wykazanie nieobecności błędów umożliwia:
    najpierw piszemy program, a potem dowodzimy twierdzenia, które mówi, że
    program działa tak jak powinien. Pisząc "twierdzenia" mam na myśli rzeczy
    analogiczne do tych znanych ci z lekcji matematyki, jak twierdzenie
    Pitagorasa, tylko że dotyczące programów, a pisząc "dowodzimy" mam na myśli
    czynność analogiczną do tej, którą wykonuje matematyk, aby upewnić się, że
    twierdzenie Pitagorasa jest prawdziwe. Wynik jest również analogiczny: tak
    jak twierdzenie Pitagorsa jest prawdziwe i nie ma co do tego najmniejszych
    wątpliwości ani nie da się go w żaden sposób podważyć, tak też twierdzenie
    o poprawności naszego programu, gdy je udowodnimy, gwarantuje nam, że w
    programie na pewno nie ma błędów.

    Morał tej bajki jest prosty: gdy programujemy w Coqu, możemy (i powinniśmy!)
    być jednocześnie matematykiem. *)

(** * Środowisko jsCoq *)

(** Środowisko, którego aktualnie używamy, nazywa się jsCoq. Jest fajne, bo
    pozwala używać Coqa bezpośrednio w przeglądarce i nie trzeba niczego
    instalować.

    Interakcja z Coqiem przebiega następująco. Po lewej mamy tekst poprzeplatany
    polami tekstowymi zawierającymi kod (można ten kod edytować - zachęcam do
    zabawy). Po prawej na dole jest okno, w którym Coq wyświetla nam informacje
    diagnostyczne, wiadomości o błędach i odpowiedzi na nasze zapytania. W oknie
    po prawej na górze póki co nie ma nic ciekawego - uaktywni się ono dopiero, gdy
    będziemy chcieli czegoś dowodzić.

    Po prawej na samej górze mamy kilka strzałek, którymi mówimy Coqowi,
    co ma robić (możemy też używać skrótów klawiszowych). Strzałka w dół
    (skrót: alt + strzałka w dół) - "wczytaj następny kawałek kodu",
    strzałka w górę (skrót: alt + strzałka w górę) - "cofnij się do
    poprzedniego kawałka kodu", podwójna strzałka (skrót: alt + enter) -
    "wczytaj cały kod aż do miejsca, w którym znajduje się kursor".

    Ok, tyle tytułem wstępu. Czas zobaczyć w końcu jakiś przykład! *)

(** * Proste typy i funkcje *)

(** Wiesz pewnie, co to bit. Otóż bit to takie coś co może być zerem lub
    jedynką. Spróbujmy zaimplementować w Coqu typ reprezentujący bity,
    napisać jakąś funkcję i coś o niej udowodnić. Uwaga: "0" i "1" nie są
    legalnymi nazwami w Coqu, więc nasze bity musimy nazwać jakoś inaczej.
    Przyjmijmy nazwy [tak] i [nie]. Uwaga 2: tekst pomiędzy znacznikami "( *"
    oraz "* )" to komentarze. Po każdej linijce kodu, która wprowadza jakąś
    nowość, będę umieszczał komentarze tłumaczące, co dana linijka oznacza. *)

Inductive        (* Definicja typu zaczyna się od słowa kluczowego "Inductive". *)
  bit : Type :=  (* "bit" jest typem zdefiniowanym w ten sposób, że: *)
    | tak : bit  (* "tak" jest elementem typu "bit" *)
    | nie : bit. (* "nie" jest elementem typu "bit" *)

(** Żeby Coq przeczytał powyższą definicję, kliknij na samej górze po prawej
    strzałkę w dół (lub wciśnij alt + strzałkę w dół). Kiedy Coq jest w trakcie
    czytania definicji, jest ona podświetlona na pomarańczowo. Jeżeli Coq ją
    zaakceptuje, zostaje ona podświetlona na szaro. Jeżeli z definicją jest coś
    nie tak, to zostanie podświetlona na czerwono, a komunikat o błędzie pojawi
    się w oknie po prawej na dole.

    Powyższa definicja, jak widać, jest w porządku. Nie pytaj na razie, skąd
    słowo kluczowe [Inductive] - dowiemy się tego później. Zauważ też, że
    definicja kończy się kropką, podobnie jak wszystkie inne komendy w Coqu.
    Samą definicję można odczytać następująco: "bit jest typem, który może
    przyjmować tylko jedną z dwóch wartości: tak albo nie".

    Co można zrobić z bitem? Zanegować! Tzn. zamienić "1" na "0", a "0" na "1"
    (co w naszym przypadku oznacza, że chcemy zamienić [tak] na [nie], a [nie]
    na [tak]). A zatem do dzieła. *)

Definition                  (* Definicja zaczyna się od słowa kluczowego "Definition". *)
  negacja : bit -> bit :=   (* negacja to funkcja, która bierze bit i zwraca bit, zdefiniowana następująco: *)
    fun b : bit =>          (* Weź jako argument bit nazwany [b]. *)
      match b with          (* Sprawdź, jakiej [b] jest postaci: *)
          | tak => nie      (* Gdy [b] to [tak], wynikiem funkcji jest [nie]. *)
          | nie => tak      (* Gdy [b] to [nie], wynikiem funkcji jest [tak]. *)
      end.

(** Uwaga: jeżeli oglądałeś moje nagranie z Dni Otwartych, to możesz tam
    zauważyć, że Coq automatycznie zamienia [->] na [→], [=>] na [→], [fun] na
    [λ], a [forall] na [∀]. Żeby nie komplikować ci życia, na niniejszej stronie
    wyłączyłem te konwersje.

    Sama definicja jest dość prosta. Definicje zaczynają się od słowa kluczowego
    [Definition] (definiować tak możemy nie tylko funkcje, ale też inne obiekty).
    Następnie podajemy nazwę definiowanej funkcji. Żeby uniknąć niepotrzebnych
    komplikacji przyjąłem konwencję, że wszystkie nasze nazwy będą w języku
    polskim. Następnie, po dwukropku, podajemy typ definiowanego obiektu (nie
    zawsze jest to konieczne, ale pisanie typów to dobry zwyczaj). Zapis [A -> B]
    oznacza typ funkcyjny, a zatem [bit -> bit] to typ funkcji, które biorą
    argument typu [bit] i zwracają wynik również typu [bit].

    Ciało definicji zaczyna się po znaku [:=]. Funkcje o typie [A -> B] mają
    postać [fun x : A => e], gdzie [e] jest wyrażeniem typu [B] mogącym używać
    argumentu [x]. Zapis ten można odczytać jako "weź argument typu A o nazwie
    x i zwróć jako wynik wyrażenie e". Nazwa argumentu nie ma znaczenia - w
    naszym przypadku zamiast [fun b : bit => match b ...] moglibyśmy równie
    dobrze napisać [fun c : bit => match c ...]

    Dalej, między słowami kluczowymi [match] i [end] wykonujemy _dopasowanie
    do wzorca_ na bicie [b]. Ponieważ typ [bit] zdefiniowaliśmy tak, że są
    tylko dwie możliwości ([tak] albo [nie]), to możemy teraz sprawdzić, którą
    z tych postaci przyjmuje [b], i w każdym z tych dwóch przypadków zwrócić
    odpowiedni wynik. Uwaga: nie możemy pominąć żadnego przypadku. Nie możemy
    też podać większej ilości przypadków, niż faktycznie jest możliwości. *)

(** * Równość *)

(** Czy nasza definicja negacji jest poprawna? Wydaje się że tak, ale pewności
    nie mamy - dobrze byłoby udowodnić jakieś twierdzenie, które nas w tym
    upewni. Zanim jednak to nastąpi, zobaczmy jak w ogóle działają w Coqu
    twierdzenia. Szczególnie zainteresowani będziemy dowodzeniem równości
    dwóch obiektów.

    Twierdzenia i dowody są jedną z najmocniejszych stron Coqa. Gdy zaczynamy
    dowód, w oknie po prawej pojawia się nasz cel, czyli to czego chcemy
    dowieść. W miarę jak wykonujemy kolejne kroki dowodu, stan okna po prawej
    zmienia się, żeby pokazać nam co musimy zrobić, co mamy do dyspozycji oraz
    co pozostało jeszcze do zrobienia. Każdy dowód możemy swobodnie przewijać
    w przód i w tył za pomocą strzałek na górze po prawej lub skrótów
    klawiszowych. Jeżeli nie rozumiesz jakiegoś dowodu, możesz powtarzać go,
    dopóki cię nie oświeci. *)

Goal tak = tak. (* Po słowie kluczowym "Goal" piszemy, co chcemy udowodnić. *)
Proof.          (* Dowód zaczynamy od słowa kluczowego "Proof". *)
  reflexivity.  (* Każda rzecz jest równa samej sobie i Coq o tym wie. *)
Qed.            (* Dowód kończymy słowem kluczowym "Qed" - od łac. "Quod erat demonstrandum" - "Co należało udowodnić" *)

(** Nasze twierdzenie jest trywialne: chcemy pokazać, że [tak] jest równe [tak].
    Dowód jest równie trywialny i sprowadza się do użycia taktyki [reflexivity].
    Po angielsku "reflexivity" znaczy "zwrotność", a "zwrotność" to w
    matematycznej mowie nazwa na fakt, że każda rzecz jest równa samej sobie -
    wiedział o tym już Arystoteles jakieś 2400 lat temu, więc nie dziwota, że
    Coq też o tym wie. Taktyka zaś to formalny, Coqowy odpowiednik nieformalnego
    sposobu rozumowania. Powiedzenie, że "każda rzecz jest równa samej sobie",
    to właśnie taki nieformalny sposób rozumowania, a taktyka [reflexivity]
    jest jego realizacją. *)

Goal tak = nie.     (* A może "tak" jest równe "nie"? Oby nie! *)
Proof.
  Fail reflexivity. (* "tak" to coś innego niż "nie" i Coq to wie - nie da się go zrobić w wała. *)
Abort.              (* Zakończenie dowodu za pomocą "Abort" oznacza, że się poddajemy. *)

(** Nie każdy sposób rozumowania jest poprawny, a zatem nie każde użycie taktyki
    kończy się sukcesem. W powyższym przykładzie rozumowanie "tak to to samo co
    nie, bo każda rzecz jest równa samej sobie" jest niepoprawne, a zatem próba
    udowodnienia tego twierdzenia za pomocą taktyki [reflexivity] zawodzi i
    musimy się poddać. Uwaga: komenda [Fail] pozwala nam zakomunikować Coqowi,
    iż spodziewamy się, że przeczytanie tego co po niej następuje zakończy się
    błędem. *)

(** * Obliczenia *)

(** Obliczenia w Coqu są wykonywane w bardzo prosty sposób - wszystko sprowadza
    się do upraszczania wyrażeń. Uczyłeś się pewnie w szkole na matematyce, że
    0 + x = x i że jeżeli mamy jakieś skomplikowane wyrażenie, w którym występuje
    0 + x, to możemy to wyrażenie uprościć do postaci, w której zamiast 0 + x
    występuje samo x.

    Każdy program w Coqu jest po prostu wyrażeniem, a jego obliczanie polega na
    wykonywaniu różnych uproszczeń. Kolejność, w jakiej wykonywane są uproszczenia,
    nie ma wpływu na wynik - zawsze wychodzi ten sam - ale może mieć wpływ na
    liczbę uproszczeń, którą trzeba wykonać. Liczba ta jednak, niezależnie od
    kolejności, zawsze jest skończona i wobec tego prędzej czy później każdy
    program zostaje maksymalnie uproszczony. Ta maksymalnie uproszczona postać
    programu nazywana jest postacią normalną i jest ona wynikiem obliczeń. *)

Goal negacja nie = tak.
Proof.
  cbn.
  reflexivity.
Qed.

(** Taktyka [cbn] realizuje sposób rozumowania "policz wynik działania programu".
    Nazwa pochodzi od angielskiego "call by name" i oznacza pewną konkretną
    kolejność, w której wykonywane są trzy podstawowe rodzaje uproszczeń, które
    zobaczymy za chwilę. *)

Goal negacja tak = nie.
Proof.
  cbv delta.   (* Pierwszym krokiem obliczeń jest odwinięcie definicji. *)
  cbv beta.    (* Kolejnym krokiem jest podstawienie wartości [tak] za argument funkcji. *)
  cbv iota.    (* Ostatnim krokiem jest wykonanie dopasowania i zwrócenie odpowiedniej wartości. *)
  reflexivity.
Qed.

(** Żeby wykonać pojedyncze uproszczenie, zamiast obliczać wszystko od razu,
    używamy taktyki [cbv], po której piszemy nazwę uproszczenia (nazwy pochodzą
    od greckich liter i są mało oświecające). Skrót "cbv" pochodzi z angielskiego
    "call by value" i, podobnie jak "cbn", oznacza pewną konkretną kolejność
    wykonywania uproszczeń.

    Są trzy główne rodzaje uproszczeń:
    - odwinięcie definicji
    - podstawienie wartości za argument funkcji
    - wykonanie dopasowania do wzorca

    Odwinięcie definicji zamienia nazwę (w naszym przypadku [negacja]) na kod,
    który ją definiuje (w naszym przypadku [fun b : bit => match b with ... end]).
    Podstawienie działa tak: jeżeli w funkcji [fun x : A => ... x ...] podstawimy
    [y] za [x], to otrzymujemy w wyniku [... y ...]

    Wykonanie dopasowania polega na sprawdzeniu, który wzorzec pasuje i zwróceniu
    odpowiadającej wartości. Wzorce sprawdzane są od góry do dołu - jeżeli pierwszy
    nie pasuje, sprawdzany jest kolejny i tak aż do skutku. Gwarantuje to nam, że
    w każdej sytuacji dopasować się może co najwyżej jeden wzorzec. Ponieważ
    definicje muszą obsługiwać wszystkie przypadki, mamy także gwarancję, że któryś
    wzorzec w końcu się dopasuje. *)

(** * Niebanalne twierdzenie *)

(** No, wreszcie czas udowodnić coś o naszej negacji. Ale co? Cóż... gdyby tak
    zanegować jakiś bit dwa razy, to powinniśmy w wyniku otrzymać to samo, co
    mieliśmy na początku, czyż nie? *)

Goal forall b : bit,         (* Dla każdego bitu b... *)
  negacja (negacja b) = b.   (* negacja negacji b jest równa b *)
Proof.
  intro dowolne_b.           (* Weźmy dowolny bit *)
  destruct dowolne_b.        (* Analiza przypadków: bit może mieć jedną z dwóch postaci (tak/nie) *)
    cbn. reflexivity.        (* Trochę obliczeń i... udało się! *)
    reflexivity.             (* Nie musimy ręcznie prosić o policzenie - Coq sam wie, żeby to zrobić. *)
Qed.

(** Nasze twierdzenie ma stosować się do każdego bitu [b], a więc nie możemy o
    tym bicie niczego założyć. Żeby to wyrazić, piszemy [forall], czyli po
    polsku "dla każdego".

    Żeby udowodnić coś o każdym bicie [b], wystarczy udowodnić to dla
    dowolnego bitu. Właśnie ten sposób rozumowania realizuje taktyka
    [intro] (argument po [intro] to nazwa, którą chcemy nadać naszemu
    dowolnemu bitowi). Po przeczytaniu linijki [intro dowolne_b.] mamy
    spore zmiany w oknie po prawej - z naszego celu zniknęło [forall
    b : bit], zaś nad kreską pojawiła się linijka [dowolne_b : bit].
    To, co znajduje się nad kreską, to kontekst - widać tam wszystkie
    nasze założenia, hipotezy oraz wszelkie inne obiekty, którymi możemy
    się posługiwać w trakcie dowodu.

    Następnie rozumujemy przez analizę przypadków. Ponieważ zdefiniowaliśmy bit
    mówiąc (a raczej pisząc), że każdy bit to albo [tak] albo [nie], to
    rozpatrzenie tych dwóch przypadków z osobna wystarcza by powiedzieć coś o
    dowolnym bicie. Właśnie ten sposób rozumowania jest realizowany przez
    taktykę [destruct]. W wyniku użycia tej taktyki mamy teraz dwa podcele: w
    pierwszym z nich [dowolne_b] zostało zastąpione przez [tak], a w drugim
    przez [nie]. W pierwszym przypadku wystarczy wykonać nieco obliczeń
    i widać wtedy, że obie strony równości są takie same. Drugi przypadek jest
    analogiczny - co więcej, jeżeli użyjemy tylko taktyki [reflexivity], to
    Coq sam połapie się, że powinien wykonać odpowiednie obliczenia. Uwaga: dla
    czytelności, dowodzenie każdego z podcelów zaczynamy od dwóch spacji wcięcia
    w kodzie.

    Tym sposobem udało nam się udowodnić nasze twierdzenie, choć być może nie
    wzbudza ono w tobie jakiegoś wybitnego entuzjazmu. Wszakże w Pythonie czy
    innym C++, aby upewnić się, że tamtejsza negacja jest poprawna, wystarczy
    napisać dwa testy. Jeżeli oba przechodzą, można ogłosić sukces i nie trzeba
    niczego dowodzić. *)

(** * Bardziej skomplikowane typy, funkcje rekurencyjne i dowody przez indukcję *)

(** Czas więc, abyśmy ujrzeli jakiś bardziej skomplikowany przykład. Interesować
    będzie nas typ, który ma nieskończenie wiele elementów. Z pewnością w Pythonie
    czy C++ nie da się napisać nieskończenie wielu testów, prawda? W Coqu zaś
    można dowodzić właściwości programów operujących na takich typach bez żadnego
    problemu. Ponieważ w językach funkcyjnych najbardziej rozpowszechnioną
    strukturą danych są listy, to właśnie one będą naszym kolejnym przykładem -
    zdefiniujemy typ reprezentujący listy bitów, dwie proste funkcje operujące
    na listach, i udowodnimy, że są one poprawne. *)

Inductive lista : Type :=
    | koniec      : lista                  (* [koniec] jest listą *)
    | na_początku : bit -> lista -> lista. (* [na_początku b l] jest listą, pod warunkiem że [b] jest bitem a [l] listą *)

(** Najpierw trochę terminologii: to, co w definicji typu piszemy po pionowej
    kresce "|", to konstruktor. A zatem konstruktorami typu [bit] są [tak] i
    [nie], zaś konstruktorami typu [lista] są [koniec] i [na_początku].
    Konstruktory danego typu służą do konstruowania jego elementów, stąd nazwa.
    Uwaga: konstruktory w Coqu nie mają nic wspólnego z konstruktorami znanymi
    z języków takich jak C++ czy Python - zbieżność nazw jest przypadkowa.

    Powyższą definicję możemy przeczytać w następujący sposób: każda lista to
    albo [koniec], albo [na_początku b l], gdzie [b] jest bitem, a [l] listą.
    [koniec] reprezentuje listę pustą (czyli taką, w której nie ma żadnych
    bitów), zaś [na_początku b l] reprezentuje listę, która powstaje z dostawienia
    bitu [b] na samym początku jakiejś innej listy [l]. Elementy typu [lista]
    mają się do bardziej tradycyjnego zapisu list (używającego kwadratowych nawiasów)
    następująco:
    - Tradycyjnie: [[]] (lista pusta). Po naszemu: [koniec].
    - Tradycyjnie: [[tak]]. Po naszemu: [na_początku tak koniec].
    - Tradycyjnie [[nie; tak]]. Po naszemu: [na_początku nie (na początku tak koniec)].
    - I tak dalej... *)

Check na_początku tak (na_początku nie (na_początku tak koniec)).
(* ===> na_początku tak (na_początku nie (na_początku tak koniec)) : lista *)

(** Żebyś miał pewność, że nie robię cię w konia, możemy poprosić Coqa żeby
    sprawdził, jakiego typu jest dany obiekt. Służy do tego komenda [Check].
    W prawym dolnym rogu Coq wyświetla swoją odpowiedź: najpierw powtarza to co
    wpisaliśmy, a potem, po dwukropku, podaje nam typ obiektu. Jak widać, Coq
    sądzi, że to, co napisaliśmy powyżej, jest elementem typu [lista] (odpowiedź
    Coqa pozwoliłem sobie skopiować i wkleić powyżej w komentarzu po znaczniku
    "===>"). Lista ta w tradycyjnym zapisie to [[tak; nie; tak]]. *)

Fixpoint na_końcu (b : bit) (l : lista) : lista :=
match l with
    | koniec           => na_początku b koniec
    | na_początku c l' => na_początku c (na_końcu b l')
end.

(** Skoro umiemy robić listy, dostawiając bit na początku, to dobrze byłoby
    też dowiedzieć się, jak dostawić bit na końcu listy. W tym celu definiujemy
    funkcję [na_końcu]. Ta funkcja będzie rekurencyjna, więc definicję musimy
    zacząć od słowa kluczowego [Fixpoint] (co znaczy słowo "fixpoint" i co ma
    wspólnego z rekurencją, nie pytaj...). [na_końcu] jest funkcją typu
    [bit -> lista -> lista], tzn. bierze jako argumenty bit oraz listę, a zwraca
    listę. Zapis jednak nieco różni się od tego, którego użyliśmy definiując
    funkcję [negacja]. Zapis [na_końcu (b : bit) (l : lista) : lista := ...]
    oznacza to samo, co
    [na_końcu : bit -> lista -> lista := fun (b : bit) (l : lista) : lista => ...],
    a jest dużo bardziej zwięzły, bo unikamy pisania typów dwa razy.

    Definicję zaczynamy od sprawdzenia, jakiej postaci jest lista [l]. Opcje
    są dwie, tak jak wynika z definicji typu [lista]. Gdy [l] to [koniec],
    wynikiem jest [na_początku b koniec] - skoro doszliśmy do końca listy, to
    dostawienie bitu na końcu jest dokładnie tym samym, co dostawienie go na
    początku. Gdy [l] to [na_początku c l'] dla jakiegoś [c : bit] oraz
    [l' : lista], wynikiem jest [na_początku c (na_końcu b l')] - ponieważ bit
    chcemy dostawić na końcu, to początek listy pozostaje bez zmian. Co jednak
    z resztą listy, czyli z [l']? Musimy na jej końcu dostawić bit [b], a zrobić
    to możemy za pomocą funkcji [na_końcu]...

    I to właśnie jest rekurencja - żeby zdefiniować funkcję [na_końcu], musimy
    użyć funkcji [na_końcu]. Innymi słowy: funkcja [na_końcu] wywołuje samą
    siebie. Mogłoby się wydawać, że coś takiego jest nielegalne ("kręcimy się w
    kółko"), ale nic bardziej mylnego: każde wywołanie rekurencyjne bierze jako
    argument coraz mniejszą listę. Ponieważ każda lista jest skończona (mimo, że
    wszystkich list razem jest nieskończenie wiele), to wywołania rekurencyjne
    prędzej czy później skonsumują całą listę i trafimy na [koniec], a wtedy
    działanie funkcji się zakończy. Definicje rekurencyjne są więc w Coqu
    dozwolone. Ba! Są naszym jedynym wyjściem - nie mamy do dyspozycji żadnych
    pętli ani niczego takiego. *)

Fixpoint odwróć (l : lista) : lista :=
match l with
    | koniec           => koniec
    | na_początku b l' => na_końcu b (odwróć l')
end.

(** Kolejną funkcją, którą chcemy zdefiniować, jest funkcja [odwróć], której
    zadaniem jest odwrócenie listy tak, żeby początek był na końcu, a koniec
    na początku. [odwróć] jest typu [lista -> lista], czyli bierze listę oraz
    zwraca listę. Podobnie jak [na_końcu] (i prawie wszystkie inne definicje
    funkcji operaujących na listach), definicja jest rekurencyjna. Najpierw
    sprawdzamy, jakiej postaci jest argument [l]. Gdy [l] to [koniec], wynikiem
    również jest [koniec] - gdy nie ma na liście żadnych bitów, nie ma czego
    odwracać. Jeżeli [l] jest postaci [na_początku b l'] dla [b : bit] oraz
    [l' : lista], to początkowy bit [b] musi powędrować na koniec wynikowej
    listy - możemy wysłać go tam za pomocą funkcji [na_końcu] - zaś reszta
    listy (czyli [l']) musi zostać rekurencyjnie odwrócona za pomocą funkcji
    [odwróć]. *)

Theorem odwróć_na_końcu :
  forall (b : bit) (l : lista),
    odwróć (na_końcu b l) = na_początku b (odwróć l).
Proof.
  intro b.
  induction l as [| głowa_l ogon_l hipoteza_indukcyjna].
    cbn. reflexivity.
    cbn. rewrite hipoteza_indukcyjna. cbn. reflexivity.
Qed.

(** Czas w końcu udowodnić jakieś twierdzenie. Tym razem zaczynamy od słowa
    kluczowego [Theorem] - jest ono konieczne, jeżeli chcemy móc nazwać nasze
    twierdzenie. A chcemy - żeby móc się do niego później odnosić. Twierdzenie
    nazywamy [odwróć_na_końcu], bo chcemy się przekonać, co się stanie, gdy
    najpierw dostawimy bit [b] na końcu listy [l], a potem całość odwrócimy.
    Odpowiedź jest prosta: oczywiście bit [b] trafi na początek odwróconej
    listy [l].

    Zaczynamy od [intro b], czyli "weźmy dowolne b". Następnym krokiem jest
    [induction l ...], co możemy przeczytać jako "indukcja po l". Indukcja to
    taka analiza przypadków na sterydach - w niektórych przypadkach do naszej
    dyspozycji dostajemy dodatkowo hipotezę indukcyjną. Indukcja jest sposobem
    rozumowania niezbędnym, gdy w grę wchodzą funkcje rekurencyjne: ponieważ
    funkcja rekurencyjna wywołuje samą siebie na mniejszym argumencie, to żeby
    udowodnić coś na jej temat dla jakiegoś argumentu, najpierw trzeba udowodnić
    tę samą własność dla mniejszego argumentu. Widzimy więc, że potrzebne jest
    nam coś w stylu wywołania rekurencyjnego, tylko że chcemy użyć tego czegoś
    do dowodzenia, a nie do definiowania funkcji... i właśnie tym czymś jest
    hipoteza indukcyjna!

    Uwaga: klauzula [as [| głowa_l ogon_l hipoteza_indukcyjna]] pozwala nam
    nadać nazwy rzeczom powstałym z rozłożenia [l] na kawałki oraz hipotezie
    indukcyjnej. W programowaniu funkcyjnym tradycyjnie pierwszy element listy
    nazywa się głową, zaś resztę ogonem, i stąd biorą się nasze nazwy.

    Indukcja pozostawia nam do udowodnienia dwa przypadki. W pierwszym [l]
    jest  postaci [koniec], a dowód jest prosty - po obu stronach równania
    jest to samo. W drugim przypadku same obliczenia już nie wystarczą, ale
    z pomocą przychodzi nam hipoteza indukcyjna, która jest równaniem postaci
    [odwróć (na_końcu b ogon_l) = na_początku b (odwróć ogon_l)] - jest to
    niemal dokładnie ta właściwość, którą chcemy udowodnić, ale dotyczy ona
    ogona [l], a nie samej listy [l].

    Zauważmy, że nasz cel również jest równaniem, zaś po jego lewej stronie
    mamy [na_końcu głowa_l (odwróć (na_końcu b ogon_l))]. Ponieważ występuje
    tutaj wyrażenie [odwróć (na_końcu b ogon_l)], to możemy użyć naszej hipotezy
    indukcyjnej, żeby zastąpić je przez [na_początku b (odwróć ogon_l)]. Żeby
    to zrobić, używamy taktyki [rewrite hipoteza_indukcyjna], która realizuje
    rozumowania polegające na przepisywaniu równań. Na koniec wystarczy trochę
    policzyć i voilà - widać, że obie strony równania są takie same. *)

Theorem odwróć_odwróć :
  forall l : lista,
    odwróć (odwróć l) = l.
Proof.
  induction l as [| głowa_l ogon_l hipoteza_indukcyjna].
    cbn. reflexivity.
    cbn. rewrite odwróć_na_końcu. rewrite hipoteza_indukcyjna. reflexivity.
Qed.

(** Udowodnijmy jeszcze, że dwukrotne odwrócenie listy daje w wyniku tę samą
    listę, co na początku. Dowód, podobnie jak poprzednio, jest przez indukcję
    po [l]. W tym momencie nie powinno nas to już dziwić - ponieważ prawie
    wszystkie funkcje operujące na listach są rekurencyjne, a dowodzenie
    właściwości funkcji rekurencyjnych wymaga rozumowania indukcyjnego, to
    prawie wszystkie dowody dotyczące list będą szły przez indukcję (wyjaśnia
    to też, dlaczego definicje typów zaczynają się od słowa kluczowego
    [Inductive]). Zauważmy, że nie musimy dowodu zaczynać taktyką [intro l] -
    gdy używamy indukcji, Coq sam wie, że powinien najpierw wprowadzić listę
    [l] do kontekstu.

    Mamy do rozpatrzenia dwa przypadki. Gdy [l] jest postaci [koniec], wystarczy
    trochę policzyć by przekonać się, że faktycznie [odwróć (odwróć koniec) = koniec].
    W drugim przypadku po wykonaniu obliczeń musimy pokazać
    [odwróć (na_końcu głowa_l (odwróć ogon_l)) = na_początku głowa_l ogon_l].
    Zauważmy, że możemy skorzystać z udowodnionego uprzednio twierdzenia
    [odwróć_na_końcu], gdyż nasz celu zawiera wyrażenie postaci
    [odwróć (na_końcu ...)]. Ponieważ twierdzenie [odwróć_na_końcu] jest po
    prostu równaniem, możemy użyć go za pomocą taktyki [rewrite]. Gdy już to
    zrobimy, po lewej stronie w naszym celu ukazuje się wyrażenie
    [odwróć (odwróć ogon_l)], które możemy uprościć korzystając z hipotezy
    indukcyjnej. I to by było na tyle, bo po obu stronach równania widzimy
    dokładnie to samo.

    W ten oto sposób udało nam się w Coqu udowodnić właściwość funkcji [odwróć],
    której nie można zagwarantować żadną liczbą testów. Czy to znaczy, że nasza
    funkcja jest poprawna? Cóż, nie do końca... wszakże [odwróć] nie jest jedyną
    funkcją [f : lista -> lista], która spełnia twierdzenie [f (f l) = l]. Żeby
    upewnić się, że [odwróć] to faktycznie ta funkcja, o którą nam chodziło,
    trzeba by udowodnić jeszcze kilka twierdzeń! *)

(** * Dlaczego warto nauczyć się Coqa? *)

(** Uważam, że warto nauczyć się Coqa (byłoby głupio, gdybym uważał inaczej,
    prawda?). Powodów jest kilka.

    Po pierwsze, programowanie funkcyjne ekspanduje i jest go wszędzie coraz
    więcej. Języki funkcyjne używane są coraz powszechniej (zdaje się, że
    najszybciej z nich rośnie Scala). Języki mainstreamowe natomiast w coraz
    większym stopniu pożyczają z języków funkcyjnych nowe konstrukty językowe
    (jeszcze kilka lat temu w C++ czy C## nie było np. funkcji anonimowych),
    style i techniki programowania (przetwarzanie strumieni w Javie), abstrakcje,
    pomysły na biblioteki i API etc. Sprawa ma się tutaj w przybliżeniu dość
    prosto: jeżeli znasz Coqa, to bardzo szybko nauczysz się każdego innego
    języka funkcyjnego oraz w mig zrozumiesz wszelkie zapożyczenia z języków
    funkcyjnych, występujące w innych językach.

    Po drugie, nauczysz się poprawnie i efektywnie rozumować o programach (nie
    tylko tych napisanych w Coqu, ale także w innych językach funkcyjnych i, w
    mniejszym stopniu, także w pozostałych językach). Jest to niesamowicie cenna
    i bardzo praktyczna umiejętność. Rozumowania równaniowe pozwalają połapać
    się podczas refaktoryzowania kodu, czy nasze zmiany przypadkiem nie zmieniły
    znaczenia programu. Umiejętność wymyślania twierdzeń, które w ogóle należy
    udowodnić na temat danej funkcji, świetnie przekłada się później w pracy na
    umiejętność wymyślania dobrych testów. Rozumowania na temat równoważności
    typów przydają się przy projektowaniu interfejsów i API (oraz znowu podczas
    refaktoringu). *)

(** * Ćwiczenia *)

(** Jeżeli dobrnąłeś aż tutaj, to gratuluję - znaczy, że musisz być całkiem
    wytrwały, a na dodatek zainteresowany tematem. Żeby nabyta w trakcie
    czytania wiedza nie uleciała, a entuzjazm nie opadł, proponuję żebyś
    wykonał parę łatwiutkich ćwiczeń.

    Oczywiście jak nie chcesz, to nie musisz robić ćwiczeń - nikt cię nie
    zmusza. To tylko taka dobra rada... *)

(* W tym okienku możesz wpisać swoje rozwiązania zadań. Może się ono wydawać
   małe, ale jak coś wpiszesz, to się powiększy :) *)

(** **** Funkcja [lub] *)

(** Zdefiniuj funkcję [lub : bit -> bit -> bit], która zwraca [tak], gdy co
    najmniej jeden z jej argumentów jest równy [tak], zaś [nie] w przeciwnym
    wypadku.

    Zanim zabierzesz się za następne zadanie, spróbuj wymyślić i udowodnić
    jakieś twierdzenie, które upewni cię, że twoja definicja jest poprawna. *)

(** **** Właściwości funkcji [lub] - zadania zamknięte *)

(** Udowodnij podstawowe właściwości funkcji [lub]:
    - Idempotencja: [forall a : bit, lub a a = a]
    - Przemienność: [forall a b : bit, lub a b = lub b a]
    - Łączność: [forall a b c : bit, lub (lub a b) c = lub a (lub b c)] *)

(** **** Właściwości funkcji [lub] - zadania otwarte *)

(** Udowodnij poniższe twierdzenia, zamieniając uprzednio symbol [?] na jakieś
    konkretne wyrażenie:
    - [forall a : bit, lub tak a = ?]
    - [forall a : bit, lub nie a = ?]
    - [forall a : bit, lub a tak = ?]
    - [forall a : bit, lub a nie = ?]
    - [forall a : bit, lub a (negacja a) = ?]
    - [forall a b : bit, negacja (lub a b) = ?] *)

(** **** Funkcja [sklej] *)

(** Zdefiniuj funkcję [sklej : lista -> lista -> lista], które bierze dwie listy i
    skleja je ze sobą, np.

    [sklej (na_początku tak koniec) (na_początku nie koniec)
    =
    na_początku tak (na_początku nie koniec)]

    Innymi słowy: [sklej l1 l2] zwraca listę, której początkiem jest lista [l1],
    zaś końcem lista [l2].

    Zanim zabierzesz się za następne zadanie, spróbuj wymyślić i udowodnić
    jakieś twierdzenie, które upewni cię, że twoja definicja jest poprawna. *)

(** **** Właściwości funkcji [sklej] - zadania zamknięte *)

(** Udowodnij podstawowe właściwości funkcji [sklej]:
    - Łączność: [forall l1 l2 l3 : lista, sklej (sklej l1 l2) l3 = sklej l1 (sklej l2 l3)] *)

(** **** Właściwości funkcji [sklej] - zadania otwarte *)

(** Udowodnij poniższe twierdzenia, zamieniając uprzednio symbol [?] na jakieś
    konkretne wyrażenie:
    - [forall l : lista, sklej koniec l = ?]
    - [forall l : lista, sklej l koniec = ?]
    - [forall (b : bit) (l1 l2 : lista), na_końcu b (sklej l1 l2) = ?]
    - [forall l1 l2 : lista, odwróć (sklej l1 l2) = ?] *)

(** * Co dalej? *)

(** ** Środowisko *)

(** Najłatwiej jest zapoznać się z Coqiem używając przeglądarkowego środowiska
    #jsCoq#.
    Polecam - nie trzeba nic instalować i ma rozsądne podpowiadanie składni dla
    początkujących.

    Jeżeli chcesz zacząć dłuższą przygodę z Coqiem, polecam go
    #zainstalować# - śmiga
    wtedy lepiej niż w przeglądarce. Musisz też wybrać sobie jakieś IDE:
    - #CoqIDE# -
      standardowe IDE do Coqa, polecam.
    - #Visual Studio Code#
      z pluginem dla Coqa - również całkiem spoko.
    - #Emacs#
      z pluginem #Proof General# -
      zdecydowanie nie polecam.
    - W ostateczności można też używać Coqa z poziomu konsoli, ale tym bardziej
      nie polecam. *)

(** ** Materiały dydaktyczne *)

(** Przyda ci się też trochę materiałów dydaktycznych:
    - #
      Nagranie z zeszłorocznych dni otwartych# (po polsku, ok. 20 min)
    - #
      Nagranie z prezentacji podobnej do naszej# (po angielsku, 3 godziny)
    - #
      Książka Software Foundations#, pierwsza połowa pierwszego tomu (po angielsku).
      Jest też #
      wersja śmigająca w jsCoqu#.

    Jeżeli słuchanie/czytanie po angielsku sprawia ci problem, możesz też
    przeczytać pierwsze rozdziały
    #
    mojej własnej twórczości (uwaga: materiał dość niekompletny i trochę
    nie po kolei; nie jest też tak odpicowany, jak niniejsza notatka). *)

(** ** Przydatne linki *)

(** Poniższe linki stanowią dobre punkty wyjścia do rozpoczęcia eksploracji
    Coqowego świata:
    - #Strona domowa#
    - #GitHub#
    - #Forum#
    - #Czat#
    - #Q&A#
    - #Lepsze Q&A#
    - #Więcej linków#
    - #Jeszcze więcej linków#

    Na stronie domowej znajdziesz więcej linków i materiałów dydaktycznych. Na
    GitHubie możesz podejrzeć, co Coqowi siedzi we flakach. Forum i tag "coq"
    na StackOverflow służą głównie do zadawania pytań. Ostatnio powstał też
    strona na StackExchange poświęcona Coqowi i językom my podobnym. Nie wiem
    co dzieje się na czacie, ale pewnie też pytania, tylko że szybciej odpowiadają :) *)

(** ** Kontakt *)

(**  Jeżeli masz pytania, pisz śmiało:
    - Ja: 299899@uwr.edu.pl
    - Nie ja: tomasz.drab@cs.uni.wroc.pl *)


From Coq Require Import Lia.
From LF Require Import Maps.
From LF Require Import Imp.

Theorem ceval_deterministic :
  forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1; intros st2 E2;
  inversion E2; subst.
  - reflexivity.
  - reflexivity.
  - rewrite (IHE1_1 st'0 H1) in *.
    apply IHE1_2.
    assumption.
  - apply IHE1.
    assumption.
  - rewrite H in H5.
    discriminate.
  - rewrite H in H5.
    discriminate.
  - apply IHE1.
    assumption.
  - reflexivity.
  - rewrite H in H2.
    discriminate.
  - rewrite H in H4.
    discriminate.
  - rewrite (IHE1_1 st'0 H3) in *.
    apply IHE1_2.
    assumption.
Qed.

Example auto_example_1 : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros P Q R H1 H2 H3.
  apply H2.
  apply H1.
  assumption.
Qed.

Example auto_example_1' : forall (P Q R: Prop),
  (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  auto.
Qed.

Example auto_example_2 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P -> Q) -> (P -> S)) ->
  T ->
  P ->
  U.
Proof.
  auto.
Qed.

Example auto_example_3 : forall (P Q R S T U: Prop),
  (P -> Q) ->
  (Q -> R) ->
  (R -> S) ->
  (S -> T) ->
  (T -> U) ->
  P ->
  U.
Proof.
  auto.
  debug auto.
  auto 6.
Qed.

(* Some common lemmas about equality and logical
operators are installed in this hint database by default. *)

Example auto_example_4 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof.
  auto.
Qed.

(* If we want to see which facts auto is using,
we can use info_auto instead.  *)

Example auto_example_5: 2 = 2.
Proof.
  info_auto.
Qed.

Example auto_example_5' : forall (P Q R S T U W: Prop),
  (U -> T) ->
  (W -> U) ->
  (R -> S) ->
  (S -> T) ->
  (P -> R) ->
  (U -> T) ->
  P ->
  T.
Proof.
  (* info_auto. *)
  intros.
  info_auto.
Qed.

Lemma le_antisym :
  forall n m: nat, (n <= m /\ m <= n) -> n = m.
Proof.
  lia.
Qed.

Example auto_example_6 : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  auto using le_antisym.
Qed.

Hint Resolve le_antisym : core.

Example auto_example_6' : forall n m p : nat,
  (n <= p -> (n <= m /\ m <= n)) ->
  n <= p ->
  n = m.
Proof.
  auto.
Qed.

Definition is_fortytwo x := (x = 42).

Hint Unfold is_fortytwo : core.

Example auto_example_7: forall x,
  (x <= 42 /\ 42 <= x) -> is_fortytwo x.
Proof.
  (* auto. *)
  info_auto.
Qed.

Theorem ceval_deterministic': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 H1 H2.
  generalize dependent st2.
  induction H1; intros st2 H2; inversion H2; subst; auto.
  - rewrite (IHceval1 st'0 H1) in *.
    auto.
  - rewrite H in H7.
    discriminate.
  - rewrite H in H7.
    discriminate.
  - rewrite H in H3.
    discriminate.
  - rewrite H in H5.
    discriminate.
  - rewrite (IHceval1 st'0 H4) in *.
    auto.
Qed.

Theorem ceval_deterministic'_alt: forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof with auto.
  intros c st st1 st2 H1 H2.
  generalize dependent st2.
  induction H1; intros st2 H2; inversion H2; subst...
  - rewrite (IHceval1 st'0 H1) in *...
  - rewrite H in H7.
    discriminate.
  - rewrite H in H7.
    discriminate.
  - rewrite H in H3.
    discriminate.
  - rewrite H in H5.
    discriminate.
  - rewrite (IHceval1 st'0 H4) in *...
Qed.

Ltac rwd H1 H2 :=
  rewrite H1 in H2 ; discriminate.

Theorem ceval_deterministic'': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof with auto.
  intros c st st1 st2 H1 H2.
  generalize dependent st2.
  induction H1; intros st2 H2; inversion H2; subst...
  - rewrite (IHceval1 st'0 H1) in *...
  - rwd H H7.
  - rwd H H7.
  - rwd H H3.
  - rwd H H5.
  - rewrite (IHceval1 st'0 H4) in *...
Qed.

Ltac find_rwd :=
  match goal with
  H1 : ?E = true,
  H2 : ?E = false
  |- _ => rwd H1 H2
  end.

Theorem ceval_deterministic''': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 H1 H2.
  generalize dependent st2.
  induction H1; intros st2 H2; inversion H2; subst;
  try find_rwd; auto.
  - rewrite (IHceval1 st'0 H1) in *.
    auto.
  - rewrite (IHceval1 st'0 H4) in *.
    auto.
Qed.

Ltac find_eqn :=
  match goal with
  H1 : forall x, ?P x -> ?L = ?R,
  H2 : ?P ?X
  |- _ => rewrite (H1 X H2) in *
end.

Theorem ceval_deterministic'''': forall c st st1 st2,
  st =[ c ]=> st1 ->
  st =[ c ]=> st2 ->
  st1 = st2.
Proof.
  intros c st st1 st2 H1 H2.
  generalize dependent st2.
  induction H1; intros st2 H2; inversion H2; subst;
  try find_rwd; try find_eqn; auto.
Qed.

Module Repeat.
  Inductive com : Type :=
  | CSkip
  | CAsgn (x : string) (v : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com)
  | CRepeat (c : com) (b : bexp).

  Notation "'repeat' x 'until' y 'end'" :=
    (CRepeat x y)
    (in custom com at level 0,
     x at level 99, y at level 99).
  Notation "'skip'" :=
    (CSkip)
    (in custom com at level 0).
  Notation "x ':=' y" :=
    (CAsgn x y)
    (in custom com at level 0,
     x constr at level 0, y at level 85).
  Notation "x ; y" :=
    (CSeq x y)
    (in custom com at level 90, right associativity).
  Notation "'if' x 'then' y 'else' z 'end'" :=
    (CIf x y z)
    (in custom com at level 89, x at level 99,
     y at level 99, z at level 99).
  Notation "'while' x 'do' y 'end'" :=
    (CWhile x y)
    (in custom com at level 89,
     x at level 99, y at level 99).

  Reserved Notation "st '=[' c ']=>' st'"
  (at level 40, c custom com at level 99,
   st' constr at next level).

  Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
    st =[ skip ]=> st
  | E_Asgn : forall st n x a1,
    aeval st a1 = n ->
    st =[ x := a1 ]=> ( x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
    st =[ c1 ]=> st' ->
    st' =[ c2 ]=> st'' ->
    st =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall b c1 c2 st st',
    beval st b = true ->
    st =[ c1 ]=> st' ->
    st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall b c1 c2 st st',
    beval st b = false ->
    st =[ c2 ]=> st' ->
    st =[ if b then c1 else c2 end ]=> st'
  | E_WhileTrue : forall b c st st' st'',
    beval st b = true ->
    st =[ c ]=> st' ->
    st' =[ while b do c end ]=> st'' ->
    st =[ while b do c end ]=> st''
  | E_WhileFalse : forall b c st,
    beval st b = false ->
    st =[ while b do c end ]=> st
  | E_RepeatEnd : forall b c st st',
    st =[ c ]=> st' ->
    beval st' b = true ->
    st =[ repeat c until b end ]=> st'
  | E_RepeatLoop : forall b c st st' st'',
    st =[ c ]=> st' ->
    beval st' b = false ->
    st' =[ repeat c until b end ]=> st'' ->
    st =[ repeat c until b end ]=> st''
  where "st =[ c ]=> st'" := (ceval c st st').

  Theorem ceval_deterministic: forall c st st1 st2,
    st =[ c ]=> st1 ->
    st =[ c ]=> st2 ->
    st1 = st2.
  Proof with auto.
    intros c st st1 st2 H1 H2.
    generalize dependent st2.
    induction H1; intros st2 H2; inversion H2;
    subst; try find_eqn; try find_rwd...
  Qed.

End Repeat.

Example ceval_example1:
  empty_st =[
    X := 2;
    if (X <= 1)
      then Y := 3
      else Z := 4
    end
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  - apply E_Asgn.
    simpl.
    reflexivity.
  - apply E_IfFalse.
    + simpl.
      reflexivity.
    + apply E_Asgn.
      simpl.
      reflexivity.
Qed.

Example ceval'_example1:
  empty_st =[
    X := 2;
    if (X <= 1)
      then Y := 3
      else Z := 4
    end
  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  eapply E_Seq.
  - apply E_Asgn.
    reflexivity.
  - apply E_IfFalse.
    + simpl.
      reflexivity.
    + apply E_Asgn.
      simpl.
      reflexivity.
Qed.

Hint Constructors ceval : core.
Hint Transparent state total_map : core.

Example eauto_example : exists s',
  (Y !-> 1 ; X !-> 2) =[
    if (X <= Y)
      then Z := Y - X
      else Y := X + Z
    end
  ]=> s'.
Proof.
  info_eauto.
Qed.

Lemma silly1 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (forall x y : nat, P x y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros P Q HP HQ.
  eapply HQ.
  apply HP.
Abort.

Lemma silly2 :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros.
  eapply H0.
  destruct H as [y H'].
  Fail apply H'.
Abort.

Lemma silly2_fixed :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros.
  destruct H as [y H'].
  eapply H0.
  apply H'.
Qed.

Lemma silly2_ssumption :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros.
  destruct H as [y H'].
  eapply H0.
  Fail assumption.
Abort.

Lemma silly2_eassumption :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros.
  destruct H.
  eapply H0.
  eassumption.
Qed.

Lemma silly2_eauto :
  forall (P : nat -> nat -> Prop) (Q : nat -> Prop),
  (exists y, P 42 y) ->
  (forall x y : nat, P x y -> Q x) ->
  Q 42.
Proof.
  intros.
  destruct H.
  eauto.
Qed.


(***************************************************************************)
(* Formalization of the Chou, Gao and Zhang's decision procedure.          *)
(* Julien Narboux (Julien@narboux.fr)                                      *)
(* LIX/INRIA FUTURS 2004-2006                                              *)
(* University of Strasbourg 2008                                           *)
(***************************************************************************)

Require  Import area_method.

(** Area elimination *)

(** on_line *)

Lemma test_area_on_line_1 : forall I B C,
  on_line I B C -> S I B C = 0.
Proof.
geoInit.
eliminate I.
basic_simpl.
auto.
Qed.

Lemma test_area_on_line_2 : forall I B C,
  on_line I B C -> S B C I = 0.
Proof.
geoInit.
eliminate I.
basic_simpl.
auto.
Qed.

Lemma test_area_on_line_3 : forall I B C,
  on_line I B C -> S B I C = 0.
Proof.
geoInit.
eliminate I.
basic_simpl.
auto.
Qed.

(** on_line_d *)

Lemma test_area_on_line_d_1 : forall I B C, forall x:F,
  on_line_d I B C x -> S B I C = 0.
Proof.
geoInit.
eliminate I.
basic_simpl.
auto.
Qed.

Lemma test_area_on_line_d_2 : forall I B C, forall x:F,
  on_line_d I B C x -> S I B C = 0.
Proof.
geoInit.
eliminate I.
basic_simpl.
auto.
Qed.

Lemma test_area_on_line_d_3 : forall I B C, forall x:F,
  on_line_d I B C x -> S B C I = 0.
Proof.
geoInit.
eliminate I.
basic_simpl.
auto.
Qed.

(* inter_ll *)

Lemma test_area_inter_ll_1 : forall I A B C D X Y,
 inter_ll I A B C D -> S X Y I = 1 / S4 A C B D * (S A C D * S X Y B + S B D C * S X Y A) .
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_inter_ll_2  : forall I A B C D X Y,
 inter_ll I A B C D -> S I X Y = 1 / S4 A C B D * (S A C D * S X Y B + S B D C * S X Y A) .
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_inter_ll_3  : forall I A B C D X Y,
 inter_ll I A B C D -> S Y I X = 1 / S4 A C B D * (S A C D * S X Y B + S B D C * S X Y A) .
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_parallel_1  : forall I B C D X Y,
 on_parallel I B C D -> S X Y I = S X Y B + B ** I / C ** D * S4 X C Y D.
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_parallel_2  : forall I B C D X Y,
 on_parallel I B C D -> S Y I X = S X Y B + B ** I / C ** D * S4 X C Y D.
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_parallel_3  : forall I B C D X Y,
 on_parallel I B C D -> S I X Y = S X Y B + B ** I / C ** D * S4 X C Y D.
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_parallel_d_1  : forall I B C D X Y r,
 on_parallel_d I B C D r -> S I X Y = S X Y B + r * S4 X C Y D.
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_parallel_d_2  : forall I B C D X Y r,
 on_parallel_d I B C D r -> S X Y I = S X Y B + r * S4 X C Y D.
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_parallel_d_3  : forall I B C D X Y r,
 on_parallel_d I B C D r -> S Y I X = S X Y B + r * S4 X C Y D.
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_inter_line_parallel_1 : forall I A B C D E X Y,
  on_inter_line_parallel I A B C D E -> False ->
  S X Y I = (S4 D B E A * S X Y C - S4 D C E A * S X Y B) / S4 D B E C .
Proof.
geoInit.
eliminate I.
2:reflexivity.
intuition.
Qed.

Lemma test_area_on_inter_parallel_parallel_1 : forall I A B C D E F X Y,
  on_inter_parallel_parallel I A B C D E F ->
  False ->
  S X Y I = S4 B D C A / S4 B E C F * S4 X E Y F + S X Y D.
Proof.
geoInit.
eliminate I.
2:reflexivity.
intuition.
Qed.

(* on_foot *)

Lemma test_area_on_foot_1  : forall I X Y Z A B,
 on_foot I X Y Z -> S A B I = (Py X Y Z * S A B Z + Py X Z Y * S A B Y) / (Py Y Z Y).
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_foot_2  : forall I X Y Z A B,
 on_foot I X Y Z -> S I A B = (Py X Y Z * S A B Z + Py X Z Y * S A B Y) / (Py Y Z Y).
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

(* on_perp_d *)

Lemma test_area_on_perp_d_1  : forall I X Y A B r,
 on_perp_d I X Y  r -> S A B I = S A B X - r / (2 + 2) * (Py X A B - Py Y A B).
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_perp_d_2  : forall I X Y A B r,
 on_perp_d I X Y  r -> S I A B = S A B X - r / (2 + 2) * (Py X A B - Py Y A B).
Proof.
geoInit.
eliminate I.
reflexivity.
Qed.

(* on_perp *)

Lemma test_area_on_perp_1  : forall I X Y A B,
 on_perp I X Y -> S I A B = S I A B.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
reflexivity.
Qed.

Lemma test_area_on_perp_2  : forall I X Y A B,
 on_perp I X Y -> S A B I = S I A B.
Proof.
intros.
prepare_half_free_construction.
eliminate I.
reflexivity.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Yannick Forster            [+]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation Saarland Univ. *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import Arith ZArith Lia List.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list gcd prime php utils_nat.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.H10.ArithLibs
  Require Import Zp lagrange.

From Undecidability.H10.Dio
  Require Import dio_logic dio_single.

From Undecidability.H10
  Require Import H10 H10_undec.

From Undecidability.H10
  Require Import H10Z.

From Undecidability.H10.ArithLibs
  Require Import Zp lagrange.

Require Import Undecidability.Synthetic.Definitions.

Set Default Proof Using "Type".

Local Definition inj k n := 4 * n + k.

Lemma injection_spec k1 k2 n m : k1 < 4 -> k2 < 4 -> inj k1 n = inj k2 m -> k1 = k2 /\ n = m.
Proof.
  intros. unfold inj in *. lia.
Qed.

Section pos_injs.

  Fixpoint inj0 {n} (p : pos n) : pos (n * 4).
  Proof.
    destruct p.
    - exact pos0.
    - exact (pos_right _ (inj0 _ p)).
  Defined.

  Fixpoint inj1 {n} (p : pos n) : pos (n * 4).
  Proof.
    destruct p.
    - exact pos1.
    - exact (pos_right _ (inj1 _ p)).
  Defined.

  Fixpoint inj2 {n} (p : pos n) : pos (n * 4).
  Proof.
    destruct p.
    - exact pos2.
    - exact (pos_right _ (inj2 _ p)).
  Defined.

  Fixpoint inj3 {n} (p : pos n) : pos (n * 4).
  Proof.
    destruct p.
    - exact pos3.
    - exact (pos_right _ (inj3 _ p)).
  Defined.

End pos_injs.

Arguments dp_cnst {V P}.
Arguments dp_var {V P}.
Arguments dp_par {V P}.
Arguments dp_comp {V P}.

Module dionat := dio_single.

Notation dp_sq a := (dp_comp do_mul a a).
Notation sq a := (a * a)%Z.

Fixpoint to_Z_poly E n (p : dionat.dio_polynomial (pos n) E) : dio_polynomial (pos (n * 4)) E :=
  match p with
  | dionat.dp_nat n => dp_cnst (Z.of_nat n)
  | dionat.dp_var v => dp_add (dp_sq (dp_var (inj3 v))) (dp_add (dp_sq (dp_var (inj2 v))) (dp_add (dp_sq (dp_var (inj1 v))) (dp_sq (dp_var (inj0 v)))))
  | dionat.dp_par p => dp_par p
  | dionat.dp_comp o p1 p2 => dp_comp o (to_Z_poly p1) (to_Z_poly p2)
  end.

Lemma create_sol_correct E (n : nat) (Φ : pos n -> nat) (Φ' : pos (n * 4) -> Z) :
  (forall i : pos n, Z.of_nat (Φ i) = sq (Φ' (inj3 i)) + sq (Φ' (inj2 i)) + sq (Φ' (inj1 i)) + sq (Φ' (inj0 i)))%Z ->
  forall p : dionat.dio_polynomial (pos n) E, Z.of_nat (dio_single.dp_eval Φ (fun _ : E => 0) p) = dp_eval Φ' (fun _ : E => 0%Z) (to_Z_poly p).
Proof.
  intros H p.
  induction p as [ k | v | | [] ]; cbn; auto.
  - rewrite H; ring.
  - rewrite Nat2Z.inj_add; congruence.
  - rewrite Nat2Z.inj_mul; congruence.
Qed.

Lemma create_sol_exists (n : nat) (Φ : pos n -> nat) : exists (Φ' : pos (n * 4) -> Z),
    (forall i : pos n, Z.of_nat (Φ i) = sq (Φ' (inj3 i)) + sq (Φ' (inj2 i)) + sq (Φ' (inj1 i)) + sq (Φ' (inj0 i)))%Z.
Proof.
  induction n as [ | n IHn ].
  - exists (fun _ => 0%Z); intros p; invert pos p.
  - destruct (IHn (fun j => Φ (pos_nxt j))) as [Φ' H'].
    cbn [mult].
    destruct (lagrange_theorem_nat (Φ pos0)) as (a & b & c & d & Hl).
    exists (fun j : pos (4 + n * 4) =>
       match pos_both _ _ j with
        | inl pos0 => a
        | inl pos1 => b
        | inl pos2 => c
        | inl _    => d
        | inr j => Φ' j
      end).
    intros p; invert pos p; auto.
    rewrite Hl; ring.
Qed.

Lemma recover_sol_exists (n : nat) (Φ' : pos (n * 4) -> Z) : exists (Φ : pos n -> nat),
    (forall i : pos n, Z.of_nat (Φ i) = sq (Φ' (inj3 i)) + sq (Φ' (inj2 i)) + sq (Φ' (inj1 i)) + sq (Φ' (inj0 i)))%Z.
Proof.
  induction n as [ | n IHn ].
  - exists (fun _ => 0); intros p; invert pos p.
  - destruct (IHn (fun j => Φ' (pos_right 4 j))) as [Φ H].
    unshelve eexists.
    + intros p; invert pos p.
      * exact (Z.to_nat (sq (Φ' (inj3 pos0)) + sq (Φ' (inj2 pos0)) + sq (Φ' (inj1 pos0)) + sq (Φ' (inj0 pos0)))).
      * exact (Φ p).
    + intros p; invert pos p.
      * rewrite Z2Nat.id; auto.
        pose proof (Z.square_nonneg (Φ' pos3)).
        pose proof (Z.square_nonneg (Φ' pos2)).
        pose proof (Z.square_nonneg (Φ' pos1)).
        pose proof (Z.square_nonneg (Φ' pos0)).
        nia.
      * apply H.
Qed.

Lemma create_sol (n : nat) (Φ : pos n -> nat) : exists Φ' : pos (n * 4) -> Z,
  forall p : dionat.dio_polynomial (pos n) (pos 0), Z.of_nat (dio_single.dp_eval Φ (fun _ => 0) p) = dp_eval Φ' (fun _ => 0%Z) (to_Z_poly p).
Proof.
  destruct (create_sol_exists Φ) as [Φ'].
  exists Φ'; intro; now eapply create_sol_correct.
Qed.

Lemma recover_sol (n : nat) (Φ' : pos (n * 4) -> Z) : exists Φ : pos n -> nat,
  forall p : dionat.dio_polynomial (pos n) (pos 0), Z.of_nat (dio_single.dp_eval Φ (fun _ => 0) p) = dp_eval Φ' (fun _ => 0%Z) (to_Z_poly p).
Proof.
  destruct (recover_sol_exists Φ') as [Φ].
  exists Φ; intro; now eapply create_sol_correct.
Qed.

Opaque Zmult.

Lemma H10_H10Z : H10 ⪯ H10Z.
Proof.
  unshelve eexists.
  - intros (n & p & q).
    exists (n * 4).
    exact (dp_add (to_Z_poly p) (dp_mul (dp_cnst (-1)%Z) (to_Z_poly q))).
  - intros (n & p & q).
    simpl; split; intros [ Φ H ]; simpl in *.
    + destruct (create_sol Φ) as [Φ' H'].
      exists Φ'.
      rewrite <- !H'; lia.
    + destruct (recover_sol Φ) as [Φ' H'].
      exists Φ'; simpl.
      apply Nat2Z.inj; rewrite !H'; lia.
Qed.

Check H10_H10Z.


(*
In this file, we show how any displayed adjunction (resp. equivalence) induces an adjunction (resp. equivalence) between the corresponding total categories.
Created by Kobe Wullaert at 06/12/2022.
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.

Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions.
Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.

Local Open Scope mor_disp_scope.
Local Open Scope type_scope.
Local Open Scope cat.

Section TotalFunctorCompositeIdentity.

  Definition total_functor_identity_inv
             {C : category} (D : disp_cat C)
    : nat_trans (total_functor (disp_functor_identity D))
                (functor_identity (total_category D)).
  Proof.
    apply nat_trans_id.
  Defined.

  Context {C1 C2 C3 : category}
          {F : functor C1 C2} {G : functor C2 C3}
          {D1 : disp_cat C1} {D2 : disp_cat C2} {D3 : disp_cat C3}
          (FF : disp_functor F D1 D2) (GG : disp_functor G D2 D3).

  Definition total_functor_comp_inv
    : nat_trans (total_functor (disp_functor_composite FF GG))
                (total_functor FF ∙ total_functor GG).
  Proof.
    apply nat_trans_id.
  Defined.

End TotalFunctorCompositeIdentity.

Section TotalAdjunction.

  Context {C1 C2 : category}
          {F : adjunction C1 C2}.

  Let L := left_functor F.
  Let R := right_functor F.
  Let η := adjunit F.
  Let ε := adjcounit F.

  Context {D1 : disp_cat C1} {D2 : disp_cat C2}
          (FF : disp_adjunction F D1 D2).

  Let LL := left_adj_over FF.
  Let RR := right_adj_over FF.
  Let ηη := unit_over FF.
  Let εε := counit_over FF.

  Definition total_adjunction_data
    : adjunction_data (total_category D1) (total_category D2).
  Proof.
    use make_adjunction_data.
    - exact (total_functor LL).
    - exact (total_functor RR).
    - use (nat_trans_comp _ _ _ (total_functor_identity D1)).
      use (nat_trans_comp _ _ _ _ (total_functor_comp_inv _ _)).
      use total_nat_trans.
      + exact η.
      + exact ηη.
    - use (nat_trans_comp _ _ _ (total_functor_comp _ _)).
      use (nat_trans_comp _ _ _ _ (total_functor_identity_inv _)).
      use total_nat_trans.
      + exact ε.
      + exact εε.
  Defined.

  Definition total_adjunction_triangle1
    : triangle_1_statement total_adjunction_data.
  Proof.
    intro x.
    use total2_paths_b.
    - cbn.
      etrans. {
        apply maponpaths.
        etrans. { apply id_left. }
        apply id_right.
      }
      etrans. {
        apply maponpaths_2.
        apply maponpaths.
        etrans. { apply id_left. }
        apply id_right.
      }
      exact (triangle_1_statement_from_adjunction F (pr1 x)).
    - cbn.
      set (t := triangle_1_over FF (pr1 x) (pr2 x)).
      unfold triangle_1_statement_over in t.
      cbn in t.

      set (a1_goal := (id_disp (pr2 x) ;; (ηη (pr1 x) (pr2 x) ;; id_disp
                                                                   (RR (left_functor F (pr1 x)) (LL (pr1 x) (pr2 x)))))).
      set (a1_t :=  (unit_over FF (pr1 x) (pr2 x))).

      assert (p : a1_goal = transportb _   (id_left (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x)))) @ id_right (η (pr1 x))) a1_t).
      {
        unfold a1_goal.
        rewrite id_right_disp.
        rewrite id_left_disp.
        now rewrite transport_b_b.
      }

      etrans. {
        apply maponpaths_2, maponpaths.
        exact p.
      }
      clear p.

      set (a2_t :=  counit_over FF (left_functor F (pr1 x)) (left_adj_over FF (pr1 x) (pr2 x))).
      set (a2_goal := (id_disp (LL (right_functor F (left_functor F (pr1 x)))
                                   (RR (left_functor F (pr1 x)) (LL (pr1 x) (pr2 x)))) ;;
                       (εε (left_functor F (pr1 x)) (LL (pr1 x) (pr2 x)) ;; id_disp (LL (pr1 x) (pr2 x))))).

      assert (p : a2_goal = transportb _  (id_left (ε (left_functor F (pr1 x)) · identity (left_functor F (pr1 x))) @ id_right (ε (left_functor F (pr1 x)))) a2_t).
      {
        unfold a2_goal.
        rewrite id_right_disp.
        rewrite id_left_disp.
        now rewrite transport_b_b.
      }

      etrans. {
        apply maponpaths.
        exact p.
      }
      clear p.

      assert (q : (# (left_functor F))
   (identity (pr1 x) · (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x)))))
 · (identity (left_functor F (right_functor F (left_functor F (pr1 x))))
    · (ε (left_functor F (pr1 x)) · identity (left_functor F (pr1 x)))) =
                    (# (left_functor F)) (adjunit F (pr1 x)) · adjcounit F (left_functor F (pr1 x))).
      {
        rewrite ! id_left.
        now rewrite ! id_right.
      }

      use pathscomp0.
      {
        exact (transportb _ q  (♯ (left_adj_over FF) (unit_over FF (pr1 x) (pr2 x)) ;; counit_over FF (left_functor F (pr1 x)) (left_adj_over FF (pr1 x) (pr2 x)))).
      }

      +  cbn.
         etrans. { apply mor_disp_transportf_prewhisker. }

         assert (hh : (# (left_functor F))
   (identity (pr1 x) · (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x)))))
 · ε (left_functor F (pr1 x)) =
                        (# (left_functor F))%Cat (adjunit F (pr1 x)) · adjcounit F (left_functor F (pr1 x))).
         {
           apply maponpaths_2.
           apply maponpaths.
           refine (id_left _ @ _).
           apply id_right.
         }

         assert (h : (maponpaths
       (compose
          ((# (left_functor F))
             (identity (pr1 x) · (η (pr1 x) · identity (right_functor F (left_functor F (pr1 x)))))))
       (! (id_left (ε (left_functor F (pr1 x)) · identity (left_functor F (pr1 x))) @
                   id_right (ε (left_functor F (pr1 x)))))) = hh @ ! q).
         {
           apply homset_property.
         }

         etrans. {
           apply maponpaths_2.
           exact h.
         }
         unfold a2_t.
         unfold transportb.
         use transportf_transpose_left.
         unfold transportb.
         rewrite transport_f_f.
         do 2 rewrite pathscomp_inv.
         rewrite path_assoc.
         rewrite pathsinv0r.
         simpl.
         rewrite disp_functor_transportf.
         use transportf_transpose_right.
         unfold transportb.
         unfold a1_t.
         rewrite mor_disp_transportf_postwhisker.
         rewrite transport_f_f.
         use transportf_set.
         apply homset_property.
      + cbn.
        etrans. {
          apply maponpaths.
          exact t.
        }
        unfold transportb.
        rewrite transport_f_f.
        use transportf_paths.
        apply homset_property.
  Qed.

  Definition total_adjunction_triangle2
    : triangle_2_statement total_adjunction_data.
  Proof.
    intro x.
    use total2_paths_b.
    - cbn.
      etrans. {
        do 2 apply maponpaths.
        etrans. { apply id_left. }
        apply id_right.
      }

      etrans. {
        apply maponpaths_2.
        etrans. { apply id_left. }
        apply id_right.
      }
      exact (triangle_2_statement_from_adjunction F (pr1 x)).
    - cbn.
      set (t := triangle_2_over FF (pr1 x) (pr2 x)).
      unfold triangle_2_statement_over in t.
      cbn in t.

      set (q := (id_left (ε (pr1 x) · identity (pr1 x)) @ id_right (ε (pr1 x)))).

      assert (p : (id_disp (LL (right_functor F (pr1 x)) (RR (pr1 x) (pr2 x))) ;; (εε (pr1 x) (pr2 x) ;; id_disp (pr2 x))) = transportb _ q (counit_over FF (pr1 x) (pr2 x))).
      {
        rewrite id_right_disp.
        rewrite id_left_disp.
        now rewrite transport_b_b.
      }

      etrans. {
        do 2 apply maponpaths.
        exact p.
      }
      clear p.
      unfold q.
      clear q.

      assert (p : identity (right_functor F (pr1 x))
 · (η (right_functor F (pr1 x)) · identity (right_functor F (left_functor F (right_functor F (pr1 x)))))
 · (# (right_functor F))%Cat
     (identity (left_functor F (right_functor F (pr1 x))) · (ε (pr1 x) · identity (pr1 x))) =
 unit_from_are_adjoints F (right_functor F (pr1 x))
                        · (# (right_functor F))%Cat (counit_from_are_adjoints F (pr1 x))).
      {
        rewrite ! id_left.
        now rewrite ! id_right.
      }

      use pathscomp0.
      {
        exact (transportb _ p (transportb (mor_disp (right_adj_over FF (pr1 x) (pr2 x)) (right_adj_over FF (pr1 x) (pr2 x))) (triangle_id_right_ad F (pr1 x)) (id_disp (right_adj_over FF (pr1 x) (pr2 x))))).
      }

      2: {
        cbn.
        rewrite transport_b_b.
        apply maponpaths_2.
        apply homset_property.
      }
      cbn.
      rewrite transport_b_b.
      unfold transportb.
      rewrite disp_functor_transportf.
      rewrite mor_disp_transportf_prewhisker.
      use transportf_transpose_left.
      unfold transportb.
      rewrite transport_f_f.

      assert (qq : identity (right_functor F (pr1 x))
 · (adjunit F (right_functor F (pr1 x))
    · identity (right_functor F (left_functor F (right_functor F (pr1 x)))))
 · (# (right_functor F))%Cat (adjcounit F (pr1 x)) =
                    adjunit F (right_functor F (pr1 x)) · (# (right_functor F))%Cat (adjcounit F (pr1 x))).
      {
        rewrite ! id_left.
        now rewrite ! id_right.
      }

      assert (q :  id_disp (RR (pr1 x) (pr2 x)) ;; (ηη (right_functor F (pr1 x)) (RR (pr1 x) (pr2 x)) ;; id_disp (RR (left_functor F (right_functor F (pr1 x))) (LL (right_functor F (pr1 x)) (RR (pr1 x) (pr2 x))))) ;; ♯ RR (counit_over FF (pr1 x) (pr2 x)) = transportb _ qq ( unit_over FF (right_functor F (pr1 x)) (right_adj_over FF (pr1 x) (pr2 x)) ;; ♯ (right_adj_over FF) (counit_over FF (pr1 x) (pr2 x)))).
      {
        rewrite id_left_disp.
        rewrite id_right_disp.
        rewrite transport_b_b.
        unfold transportb.
        rewrite mor_disp_transportf_postwhisker.
        apply maponpaths_2.
        apply homset_property.
      }

      refine (q @ _).
      etrans. {
        apply maponpaths.
        exact t.
      }
      rewrite transport_b_b.
      unfold transportb.
      use maponpaths_2.
      apply homset_property.
  Qed.

  Definition total_adjunction
    : adjunction (total_category D1) (total_category D2).
  Proof.
    use make_adjunction.
    - exact total_adjunction_data.
    - split.
      + apply total_adjunction_triangle1.
      + apply total_adjunction_triangle2.
  Defined.

End TotalAdjunction.

Section TotalEquivalence.

  Context {C1 C2 : category}
          {F : adj_equiv C1 C2}.

  Let L := left_functor F.
  Let R := right_functor F.
  Let η := adjunit F.
  Let ε := adjcounit F.

  Context {D1 : disp_cat C1}
          {D2 : disp_cat C2}
          (FF : equiv_over F D1 D2).

  Let LL := left_adj_over FF.
  Let RR := right_adj_over FF.
  Let ηη := unit_over FF.
  Let εε := counit_over FF.

  Definition total_adjunction_forms_equivalence1_base
    : ∏ x : total_category D1, is_z_isomorphism (pr1 (adjunit (total_adjunction FF) x)).
  Proof.
    intro x.
    use is_z_iso_comp_of_is_z_isos.
    - apply Isos.identity_is_z_iso.
    - use Isos.is_z_iso_comp_of_is_z_isos.
      + apply (adj_equiv_of_cats_from_adj F).
      + apply Isos.identity_is_z_iso.
  Defined.

  Definition total_adjunction_forms_equivalence1_disp_inv
    : ∏ x : total_category D1,
        RR (F (pr1 x)) (LL (pr1 x) (pr2 x))
           -->[identity (R (F (pr1 x))) · is_z_isomorphism_mor ((pr122 F) (pr1 x)) · identity (pr1 x)]
           pr2 x.
  Proof.
    intro x.
    set (f := pr1 (pr12 FF (pr1 x) (pr2 x))).
    assert (p : identity (right_adjoint F (F (pr1 x))) · Isos.is_z_isomorphism_mor ((pr122 F) (pr1 x)) · identity (pr1 x) = Isos.is_z_isomorphism_mor ((pr122 F) (pr1 x))).
    {
      rewrite id_left.
      now apply id_right.
    }
    exact (transportf (mor_disp _ _) (! p) f).
  Defined.

  Lemma total_adjunction_forms_equivalence1_disp_inv_is_inv
    : ∏ x : total_category D1,
        is_disp_inverse
          (z_iso_is_inverse_in_precat
             (pr1 (adjunit (total_adjunction FF) x),, total_adjunction_forms_equivalence1_base x))
          (pr2 (adjunit (total_adjunction FF) x))
          (total_adjunction_forms_equivalence1_disp_inv x).
  Proof.
    unfold total_adjunction_forms_equivalence1_base.
    unfold total_adjunction_forms_equivalence1_disp_inv.
    split.
    - cbn.
      use transportf_transpose_right.
      unfold transportb.
      rewrite mor_disp_transportf_postwhisker.
      rewrite transport_f_f.
      cbn.

      set (ff := pr12 (pr12 FF (pr1 x) (pr2 x))).
      cbn in ff.
      set (fff := transportf_transpose_left ff).
      refine (_ @ fff).
      use transportf_transpose_right.
      unfold transportb.
      rewrite transport_f_f.
      rewrite id_right_disp.
      rewrite id_left_disp.
      rewrite transport_b_b.
      unfold transportb.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      use transportf_set.
      apply homset_property.
    - cbn.
      use transportf_transpose_right.
      unfold transportb.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      cbn.

      set (ff := pr22 (pr12 FF (pr1 x) (pr2 x))).
      cbn in ff.
      set (fff := transportf_transpose_left ff).
      refine (_ @ fff).
      use transportf_transpose_right.
      unfold transportb.
      rewrite transport_f_f.
      rewrite id_right_disp.
      rewrite id_left_disp.
      rewrite transport_b_b.
      unfold transportb.
      rewrite mor_disp_transportf_postwhisker.
      rewrite transport_f_f.
      use transportf_set.
      apply homset_property.
  Qed.

  Definition total_adjunction_forms_equivalence1
    : ∏ a : total_category D1, Isos.is_z_isomorphism (adjunit (total_adjunction FF) a).
  Proof.
    intro x.
    use is_z_iso_total.
    - exact (total_adjunction_forms_equivalence1_base x).
    - exists (total_adjunction_forms_equivalence1_disp_inv x).
      exact (total_adjunction_forms_equivalence1_disp_inv_is_inv x).
  Defined.

  Definition total_adjunction_forms_equivalence2_base
    :  ∏ b : total_category D2, Isos.is_z_isomorphism (pr1 (adjcounit (total_adjunction FF) b)).
  Proof.
    intro.
    use Isos.is_z_iso_comp_of_is_z_isos.
    - apply Isos.identity_is_z_iso.
    - use Isos.is_z_iso_comp_of_is_z_isos.
      + apply (adj_equiv_of_cats_from_adj F).
      + apply Isos.identity_is_z_iso.
  Defined.

  Definition total_adjunction_forms_equivalence2_disp_inv
    : ∏ x : total_category D2,
          pr2 (functor_identity (total_category D2) x) -->[
  inv_from_z_iso (pr1 (adjcounit (total_adjunction FF) x),, total_adjunction_forms_equivalence2_base x)]
              pr2 ((pr121 (total_adjunction FF) ∙ pr11 (total_adjunction FF)) x).
  Proof.
    intro x.
    set (f := pr1 (pr22 FF (pr1 x) (pr2 x))).
    cbn.
    assert (p :  identity (pr1 x) · Isos.is_z_isomorphism_mor ((pr222 F) (pr1 x))
                          · identity (F (right_adjoint F (pr1 x))) = Isos.is_z_isomorphism_mor ((pr222 F) (pr1 x))).
    {
      rewrite id_left.
      now apply id_right.
    }
    exact (transportf (mor_disp _ _) (! p) f).
  Defined.

  Lemma total_adjunction_forms_equivalence2_disp_inv_is_inv
    : ∏ x : total_category D2,
         is_disp_inverse
           (z_iso_is_inverse_in_precat
              (pr1 (adjcounit (total_adjunction FF) x),, total_adjunction_forms_equivalence2_base x))
           (pr2 (adjcounit (total_adjunction FF) x))
           (total_adjunction_forms_equivalence2_disp_inv x).
  Proof.
    unfold total_adjunction_forms_equivalence2_base.
    unfold total_adjunction_forms_equivalence2_disp_inv.
    split.
    - cbn.
      use transportf_transpose_right.
      unfold transportb.
      rewrite mor_disp_transportf_postwhisker.
      rewrite transport_f_f.
      cbn.

      set (ff := pr12 (pr22 FF (pr1 x) (pr2 x))).
      cbn in ff.
      set (fff := transportf_transpose_left ff).
      refine (_ @ fff).
      use transportf_transpose_right.
      unfold transportb.
      rewrite transport_f_f.
      rewrite id_right_disp.
      rewrite id_left_disp.
      rewrite transport_b_b.
      unfold transportb.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      use transportf_set.
      apply homset_property.
    - cbn.
      use transportf_transpose_right.
      unfold transportb.
      rewrite mor_disp_transportf_prewhisker.
      rewrite transport_f_f.
      cbn.

      set (ff := pr22 (pr22 FF (pr1 x) (pr2 x))).
      cbn in ff.
      set (fff := transportf_transpose_left ff).
      refine (_ @ fff).
      use transportf_transpose_right.
      unfold transportb.
      rewrite transport_f_f.
      rewrite id_right_disp.
      rewrite id_left_disp.
      rewrite transport_b_b.
      unfold transportb.
      rewrite mor_disp_transportf_postwhisker.
      rewrite transport_f_f.
      use transportf_set.
      apply homset_property.
  Qed.

  Definition total_adjunction_forms_equivalence2
    :  ∏ b : total_category D2, Isos.is_z_isomorphism (adjcounit (total_adjunction FF) b).
  Proof.
    intro x.
    use is_z_iso_total.
    - exact (total_adjunction_forms_equivalence2_base x).
    - exists (total_adjunction_forms_equivalence2_disp_inv x).
      exact (total_adjunction_forms_equivalence2_disp_inv_is_inv x).
  Defined.

  Definition total_adjunction_forms_equivalence
    : forms_equivalence (total_adjunction FF).
  Proof.
    split.
    - exact total_adjunction_forms_equivalence1.
    - exact total_adjunction_forms_equivalence2.
  Defined.

  Definition total_adj_equivalence_of_cats
    : adj_equivalence_of_cats (total_functor LL).
  Proof.
    exists (total_adjunction FF).
    exact total_adjunction_forms_equivalence.
  Defined.

  Definition total_equivalence
    : adj_equiv (total_category D1) (total_category D2).
  Proof.
    exists (left_functor (total_adjunction FF)).
    exact total_adj_equivalence_of_cats.
  Defined.

End TotalEquivalence.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

 This defines the formal syntax, pg. 61.

*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Coq.Bool.Bool.

Require Import FormalSyntax.
Require Import Case.

Fixpoint subst_Tau (t : Tau) (tau : Tau) (alpha : TVar) {struct t} : Tau :=
  match t with
    | tv_t beta  =>
       if beq_tvar alpha beta then tau else tv_t beta
    | cint               => cint
    | cross t0 t1        => cross (subst_Tau t0 tau alpha) (subst_Tau t1 tau alpha)
    | arrow t0 t1        => arrow (subst_Tau t0 tau alpha) (subst_Tau t1 tau alpha)
    | ptype t0           => ptype (subst_Tau t0 tau alpha)
(* Bug 41, assuming beta != alpha ! Block not alpha convert.*)
    | utype   beta k t'  =>
       if beq_tvar alpha beta then t else utype beta k (subst_Tau t' tau alpha)
    | etype p beta k t'  =>
       if beq_tvar alpha beta then t else etype p beta k (subst_Tau t' tau alpha)
end.

Fixpoint subst_E (e : E) (tau : Tau) (alpha : TVar) {struct e} : E :=
 match e with
   | i_e i        => i_e i
   | p_e x p      => p_e x p
   | f_e f        =>        (f_e (subst_F   f  tau alpha))
   | amp e'       => amp    (subst_E   e'     tau alpha)
   | star e'      => star   (subst_E   e'     tau alpha)
   | cpair e1 e2  => cpair  (subst_E   e1     tau alpha) (subst_E e2 tau alpha)
   | dot e' i     => dot    (subst_E   e'     tau alpha) i
   | assign e1 e2 => assign (subst_E   e1     tau alpha) (subst_E e2 tau alpha)
   | appl  e1 e2  => appl   (subst_E   e1     tau alpha) (subst_E e2 tau alpha)
   | call s       => call   (subst_St  s      tau alpha)
   | inst e' t    => inst   (subst_E   e'     tau alpha) (subst_Tau t tau alpha)
   | pack t e' t' => pack   (subst_Tau t tau alpha) (subst_E e' tau alpha) (subst_Tau t' tau alpha)
 end
with subst_St (s: St) (tau : Tau) (alpha : TVar) {struct s} : St :=
  match s with
    | e_s e                => e_s      (subst_E e tau alpha)
    | retn e                => retn      (subst_E e tau alpha)
    | seq s1 s2            => seq      (subst_St s1 tau alpha) (subst_St s2 tau alpha)
    | if_s e s1 s2         => if_s     (subst_E e tau alpha)  (subst_St s1 tau alpha) (subst_St s2 tau alpha)
    | while e s            => while    (subst_E e tau alpha)  (subst_St s tau alpha)
    | letx x e s           => letx  x  (subst_E e tau alpha)  (subst_St s tau alpha)
    | open     e beta x s  => open     (subst_E e tau alpha) beta x (subst_St s tau alpha)
    | openstar e beta x s  => openstar (subst_E e tau alpha) beta x (subst_St s tau alpha)
end
with subst_F (f : F) (tau : Tau) (alpha : TVar) {struct f} : F  :=
 match f with
   | (dfun tau1 x tau2 s) =>
     (dfun (subst_Tau tau1 tau alpha) x (subst_Tau tau2 tau alpha) (subst_St s tau alpha))
   (* Bug 7 from test. *)
   | ufun (tvar b) k f =>
     match alpha with
         (tvar a) =>
         if (beq_nat a b)
         then (ufun alpha k f)
         else  (ufun (tvar b) k (subst_F f tau alpha))
     end
end.

Fixpoint subst_Gamma (g : Gamma) (tau : Tau) (alpha : TVar) : Gamma :=
  match g with
   | [] => []
   | (x, tau') :: g' =>
     (x, (subst_Tau tau' tau alpha)) ::
           (subst_Gamma g' tau alpha)
end.
Functional Scheme subst_Gamma_ind := Induction for subst_Gamma Sort Prop.

Lemma subst_Gamma_over_app:
  forall (tau : Tau) (alpha : TVar) (x y : Gamma),
    subst_Gamma (x ++ y) tau alpha =
    (subst_Gamma x tau alpha) ++ (subst_Gamma y tau alpha).
Proof.
  intros tau alpha x y.
  induction x.
  Case "x = []".
   simpl.
   reflexivity.
  Case "x = a :: x".
  destruct a.
  unfold subst_Gamma.
  fold subst_Gamma.
  rewrite <- app_comm_cons.
  unfold subst_Gamma.
  fold subst_Gamma.
  rewrite IHx.
  reflexivity.
Qed.

Function NotFreeInTau (beta : TVar) (tau : Tau) : Prop :=
  match tau with
    | tv_t alpha =>
      if beq_tvar beta alpha then False else True
    | cint        => True
    | cross t0 t1 =>
       (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | arrow t0 t1 =>
        (NotFreeInTau beta t0) /\ (NotFreeInTau beta t1)
    | ptype t     => NotFreeInTau beta t
    | utype alpha _ t =>
      if beq_tvar beta alpha then True else NotFreeInTau beta t
    | etype _ alpha _ t =>
      if beq_tvar beta alpha then True else NotFreeInTau beta t
  end.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Category Category.Morph Category.Opposite.
From Categories Require Import Ext_Cons.Arrow.
From Categories Require Import Functor.Functor Functor.Functor_Ops Const_Func.
From Categories Require Import Archetypal.Discr.Discr.
From Categories Require Import Cat.Cat Cat.Cat_Iso.
From Categories Require Import NatTrans.NatTrans NatTrans.NatIso.

Local Open Scope morphism_scope.

(**
A comma category for Functors F : B → C and G : D → C is a category whose
objects are arrows in C

#

   F _o x ———————–> G _o y

#

for x an object of B and y an object of D. Arrows of comma are commutative
diagrams in C:

#

         F _o x ———————–> G _o y
           |                |
           |                |
   F _a h  |                |  F _a h'
           |                |
           |                |
           ↓                ↓
         F _o x' ———————–> G _o y'

#

for h : x → x' an arrow in B and h' : y → y' an arrow in G.

*)
Section Comma.
  Context {B C D : Category} (F : (B –≻ C)%functor) (G : (D –≻ C)%functor).

  Record Comma_Obj : Type :=
    {
      CMO_src : B;
      CMO_trg : D;
      CMO_hom : ((F _o CMO_src) –≻ (G _o CMO_trg))%object
    }.

  Record Comma_Hom (a b : Comma_Obj) : Type :=
    {
      CMH_left : (CMO_src a) –≻ (CMO_src b);
      CMH_right : (CMO_trg a) –≻ (CMO_trg b);
      CMH_com :  ((G _a CMH_right) ∘ (@CMO_hom a) =
                  (@CMO_hom b) ∘ (F _a CMH_left))%morphism
    }.

  Arguments CMH_left {_ _} _.
  Arguments CMH_right {_ _} _.
  Arguments CMH_com {_ _} _.

  Theorem Comma_Hom_eq_simplify {a b : Comma_Obj} (h h' : Comma_Hom a b) :
    (@CMH_left _ _ h) = (@CMH_left _ _ h') →
    (@CMH_right _ _ h) = (@CMH_right _ _ h') → h = h'.
  Proof.
    intros H1 H2.
    destruct h; destruct h'.
    cbn in *.
    ElimEq.
    PIR.
    trivial.
  Qed.

  Program Definition Comma_Hom_compose
          {a b c : Comma_Obj} (h : Comma_Hom a b) (h' : Comma_Hom b c) :
    Comma_Hom a c :=
    {|
      CMH_left := (CMH_left h') ∘ (CMH_left h);
      CMH_right := (CMH_right h') ∘ (CMH_right h)
    |}.

  Next Obligation.
  Proof.
    repeat rewrite F_compose.
    rewrite assoc.
    rewrite CMH_com.
    rewrite assoc_sym.
    rewrite CMH_com.
    auto.
  Qed.

  Theorem Comma_Hom_compose_assoc {a b c d : Comma_Obj} (h : Comma_Hom a b)
          (h' : Comma_Hom b c) (h'' : Comma_Hom c d) :
    Comma_Hom_compose h (Comma_Hom_compose h' h'') =
    Comma_Hom_compose (Comma_Hom_compose h h') h''.
  Proof.
    apply Comma_Hom_eq_simplify; cbn; auto.
  Qed.

  Program Definition Comma_Hom_id (a : Comma_Obj) : Comma_Hom a a :=
    {|
      CMH_left := id;
      CMH_right := id
    |}.

  Theorem Comma_Hom_id_unit_left {a b : Comma_Obj} (h : Comma_Hom a b) :
    Comma_Hom_compose h (Comma_Hom_id b) = h.
  Proof.
    apply Comma_Hom_eq_simplify; cbn; auto.
  Qed.

  Theorem Comma_Hom_id_unit_right {a b : Comma_Obj} (h : Comma_Hom a b) :
    Comma_Hom_compose (Comma_Hom_id a) h = h.
  Proof.
    apply Comma_Hom_eq_simplify; cbn; auto.
  Qed.

  Definition Comma : Category :=
    {|
      Obj := Comma_Obj;

      Hom := Comma_Hom;

      compose := @Comma_Hom_compose;

      assoc := @Comma_Hom_compose_assoc;

      assoc_sym := fun _ _ _ _ f g h => eq_sym (Comma_Hom_compose_assoc f g h);

      id := Comma_Hom_id;

      id_unit_right := @Comma_Hom_id_unit_right;

      id_unit_left := @Comma_Hom_id_unit_left
    |}.

End Comma.

Arguments CMO_src {_ _ _ _ _} _.
Arguments CMO_trg {_ _ _ _ _} _.
Arguments CMO_hom {_ _ _ _ _} _.
Arguments CMH_left {_ _ _ _ _ _ _} _.
Arguments CMH_right {_ _ _ _ _ _ _} _.
Arguments CMH_com {_ _ _ _ _ _ _} _.

(** In this section we show that the opposite the comma category of (Comma F G)
is isomorphic to the comma category (Comma Gᵒᵖ Fᵒᵖ).
 *)
Section Comma_Opposite_Iso.
  Context {B C D : Category} (F : (B –≻ C)%functor) (G : (D –≻ C)%functor).

  Local Hint Extern 1 => progress cbn.

  Local Hint Extern 1 => apply Comma_Hom_eq_simplify.

  Program Definition Comma_Opposite_Iso_LR :
    Functor ((Comma F G)^op) (Comma (G ^op) (F ^op))
    :=
      {|
        FO :=
          fun x =>
            {|
              CMO_src := CMO_trg x;
              CMO_trg := CMO_src x;
              CMO_hom := CMO_hom x
            |};
        FA :=
          fun c c' h =>
            {|
              CMH_left := CMH_right h;
              CMH_right := CMH_left h;
              CMH_com := eq_sym (CMH_com h)
            |}
      |}.

  Program Definition Comma_Opposite_Iso_RL :
    Functor (Comma (G ^op) (F ^op)) ((Comma F G)^op)
    :=
      {|
        FO :=
          fun x =>
            {|
              CMO_src := CMO_trg x;
              CMO_trg := CMO_src x;
              CMO_hom := CMO_hom x
            |};
        FA :=
          fun c c' h =>
            {|
              CMH_left := CMH_right h;
              CMH_right := CMH_left h;
              CMH_com := eq_sym (CMH_com h)
            |}
      |}.

  Program Definition Comma_Opposite_Iso :
    (((Comma F G)^op)%category ≃≃ Comma (G ^op) (F ^op) ::> Cat)%isomorphism
    :=
      {|
        iso_morphism := Comma_Opposite_Iso_LR;
        inverse_morphism := Comma_Opposite_Iso_RL
      |}
  .

End Comma_Opposite_Iso.

(** In this section we show that whenever F and F' are two naturally
isomorphic functors, then (Comma F G) is isomorphic to (Comma F' G).
 *)
Section Comma_Left_Func_Iso.
  Context {B C D : Category}.

  Local Hint Extern 1 => progress cbn.

  Local Hint Extern 1 => apply Comma_Hom_eq_simplify.

  Section Comma_Left_Func_Iso_FC.
    Context
      {F F' : (B –≻ C)%functor}
      (I : (F ≃ F')%natiso)
      (G : (D –≻ C)%functor)
    .

    (** Given a natural isomorphism we build a functor. *)
    Program Definition Comma_Left_Func_Iso_FC :
      Functor (Comma F G) (Comma F' G)
      :=
        {|
          FO :=
            fun x =>
              {|
                CMO_src := CMO_src x;
                CMO_trg := CMO_trg x;
                CMO_hom := (CMO_hom x) ∘ (Trans (inverse_morphism I) (CMO_src x))
              |};
          FA :=
            fun c c' h =>
              {|
                CMH_left := CMH_left h;
                CMH_right := CMH_right h;
              CMH_com := _
              |}
        |}.

    Next Obligation.
    Proof.
      rewrite assoc_sym.
      rewrite (CMH_com h).
      rewrite assoc.
      rewrite <- (Trans_com (inverse_morphism I) (CMH_left h)).
      auto.
    Qed.

  End Comma_Left_Func_Iso_FC.

  Section Comma_Left_Func_Iso_FC_Iso.
    Context
      {F F' : (B –≻ C)%functor}
      (I : (F ≃ F')%natiso)
      (G : (D –≻ C)%functor)
    .

    (** Functors produced from a natural isomorphism and its inverse
are inverses.
*)
    Lemma Comma_Left_Func_Iso_FC_Iso :
      ((Comma_Left_Func_Iso_FC I G)
         ∘
         (Comma_Left_Func_Iso_FC (Inverse_Isomorphism I) G))%functor
      =
      Functor_id _
    .
    Proof.
      Func_eq_simpl.
      {
        extensionality x.
        extensionality y.
        extensionality f.
        match type of H with
          ?A = ?B =>
          set (H' :=
                 fun x =>
                   match H in _ = y return
                         A x = y x
                   with
                     eq_refl => eq_refl
                   end
              )
        end.
        transitivity (
            match H' x in _ = u return
                  u –≻ _
            with
              eq_refl =>
              match H' y in _ = v return
                    _ –≻ v
              with
                eq_refl =>
                ((Comma_Left_Func_Iso_FC I G ∘ Comma_Left_Func_Iso_FC (I ⁻¹) G) _a f)
              end
            end
          ).
        {
          destruct H; trivial.
        }
        {
          apply Comma_Hom_eq_simplify.
          {
            apply JMeq_eq.
            destruct H; trivial.
          }
          {
            apply JMeq_eq.
            destruct H; trivial.
          }
        }
      }
      {
        extensionality x.
        destruct x as [s t h]; cbn.
        rewrite assoc.
        change ((Trans (iso_morphism I) s) ∘ Trans (I ⁻¹)%morphism s) with
        (Trans ((iso_morphism I) ∘ (I ⁻¹)%morphism) s).
        cbn_rewrite (right_inverse I).
        cbn; auto.
      }
    Qed.

  End Comma_Left_Func_Iso_FC_Iso.

  Context
    {F F' : (B –≻ C)%functor}
    (I : (F ≃ F')%natiso)
    (G : (D –≻ C)%functor)
  .

  Local Hint Extern 1 => apply Comma_Left_Func_Iso_FC_Iso.

  Program Definition Comma_Left_Func_Iso :
    ((Comma F G) ≃≃ (Comma F' G) ::> Cat)%isomorphism
    :=
      {|
        iso_morphism := Comma_Left_Func_Iso_FC I G;
        inverse_morphism := Comma_Left_Func_Iso_FC (Inverse_Isomorphism I) G
      |}
  .

End Comma_Left_Func_Iso.

(** In this section we show that whenever G and G' are two naturally
isomorphic functors, then (Comma F G) is isomorphic to (Comma F G').
This follows from Comma_Left_Func_Iso and Comma_Opposite_Iso proven
above.
 *)
Section Comma_Right_Func_Iso.
  Context
    {B C D : Category}
    (F : (B –≻ C)%functor)
    {G G' : (D –≻ C)%functor}
    (I : (G ≃ G')%natiso)
  .

  Definition Comma_Right_Func_Iso :
    ((Comma F G) ≃≃ (Comma F G') ::> Cat)%isomorphism :=
    Isomorphism_Compose
      (
        Isomorphism_Compose
          (Inverse_Isomorphism (Comma_Opposite_Iso (G ^op) (F ^op)))
          (Opposite_Cat_Iso (Comma_Left_Func_Iso (Opposite_NatIso I) (F^op)))
      )
      (Comma_Opposite_Iso (G' ^op) (F ^op))
  .

End Comma_Right_Func_Iso.

(**
Slice, coslice and arrow categories are special cases of comma categories
defined below:
*)

Section Slice_CoSlice.
  Context (C : Category) (c : Obj).

  (**
   The Slice of Category C with respect to c:
     Objects : Arrows of C ending in c
     Arrows: for g : a → c and h : b → c, an arrow from g to h is a pair of
       arrows f : a → b s.t. the ollowing commutes:

#

           g
         a –––→ c
         |     ↗
         ∣    /
        f∣   / h
         |  /
         ↓ /
         b

#
   *)

  Definition Slice : Category := Comma (Functor_id _) (Const_Func 1 c).

  (**
   The Slice of Category C with respect to c:
     Objects : Arrows of C ending in c
     Arrows: for g : a → c and h : b → c,
       an arrow from g to h is a pair of arrows f : a → b s.t. the ollowing commutes:

#

            g
         c ←––– a
         ↑     /
         ∣    /
        h∣   / f
         |  /
         | ↙
         b

#
   *)

  Definition CoSlice : Category := Comma (Const_Func 1 c) (Functor_id _).

End Slice_CoSlice.

Section Arrow_Cat.
  Context (C : Category).

  (**
   The Arrow Category of C:
     Objects : Arrows of C
     Arrows: for g : a → b and h : c → d,
       an arrow from g to h is a pair of arrows (f,f') s.t. the ollowing commutes:

#

             g
         a ––––→ b
         ∣       ∣
        f∣       ∣f'
         ↓       ↓
         c –——–→ d
             h

#
   *)

  Definition Arrow_Cat : Category := Comma (Functor_id C) (Functor_id C).

End Arrow_Cat.