module Basic.BigStep where

import Data.Bool as Bool using (not)
open import Data.Bool hiding (not; if_then_else_)
open import Data.Empty
open import Data.Fin using (Fin; suc; zero; #_)
open import Data.Nat
open import Data.Nat.Properties.Simple
open import Data.Vec
open import Function
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Product
import Level as L

open import Utils.Decidable
open import Utils.NatOrdLemmas
open import Basic.AST

{-
The big-step semantics of the while language. It's chapter 2.1 in the book.

Note that we use a {n : ℕ} parameter to fix the size of the program state over
our derivations. This is fine since we don't have any derivation rule that
changes the size of the state.

The definitions themselves should come as no surprise to readers of the book.

I employ some syntactic shenanigans to make the definitions visually similar to the familiar
sequent/natural calculus notation (I borrow the formatting style from Conor McBride).
-}

infixr 4 _,_
data ⟨_,_⟩⟱_ {n : ℕ} : St n → State n → State n → Set where

  {- "[ x ]≔ value" is just the standard library definition of vector update -}
  ass :
                   ∀ {s x a}
    → ------------------------------------
      ⟨ x := a , s ⟩⟱ (s [ x ]≔ ⟦ a ⟧ᵉ s)

  skip :
           ∀ {s}
    → -----------------
      ⟨ skip , s ⟩⟱ s

  _,_ :
              ∀ {s₁ s₂ s₃ S₁ S₂} →
      ⟨ S₁ , s₁ ⟩⟱ s₂  →  ⟨ S₂ , s₂ ⟩⟱ s₃
    → -------------------------------------
             ⟨ (S₁ , S₂ ) , s₁ ⟩⟱ s₃

  {- The "T" in "T (⟦ b ⟧ᵉ s)" can be found in Data.Bool.Base. It's ⊤ on a true argument
     and ⊥ on a false argument, so it just lifts boolean values to proofs.
     "F" works the same way, except it's provable on a false argument -}

  if-true :
             ∀ {s s' S₁ S₂ b} →
       T (⟦ b ⟧ᵉ s)  →  ⟨ S₁ , s ⟩⟱ s'
    → -----------------------------------
       ⟨ if b then S₁ else S₂ , s ⟩⟱ s'

  if-false :
              ∀ {s s' S₁ S₂ b} →
       F (⟦ b ⟧ᵉ s)  →  ⟨ S₂ , s ⟩⟱ s'
    → -----------------------------------
       ⟨ if b then S₁ else S₂ , s ⟩⟱ s'

  while-true :
                          ∀ {s s' s'' S b} →
       T (⟦ b ⟧ᵉ s)  →  ⟨ S , s ⟩⟱ s'  →  ⟨ while b do S , s' ⟩⟱ s''
    → ----------------------------------------------------------------
                       ⟨ while b do S , s ⟩⟱ s''

  while-false :
            ∀ {s S b} →
            F (⟦ b ⟧ᵉ s)
    → ------------------------
      ⟨ while b do S , s ⟩⟱ s

{-
Example program and program derivation below.
Note the magnificient de Bruijn variables.

Program derivations are really slow to typecheck.
Brave souls may want to uncomment it and give it a try.
But other than that, we may should that the derivations look pretty clean and concise.
There's lots of details that Agda's inference can fill in for us.

-}
private
  prog : St 3
  prog =
    # 2 := lit 0 ,
    while lte (var (# 1)) (var (# 0)) do
      ( # 2 := add (var (# 2)) (lit 1) ,
        # 0 := sub (var (# 0)) (var (# 1)) )

  -- -- uncomment if you dare
  -- prog-deriv :
  --   ∀ {z} → ⟨ prog , 17 ∷ 5 ∷ z ∷ [] ⟩⟱ (2 ∷ 5 ∷ 3 ∷ [])
  -- prog-deriv =
  --   ass ,
  --   while-true tt (ass , ass)
  --     (while-true tt (ass , ass)
  --       (while-true tt (ass , ass)
  --         (while-false tt)))

{- A program diverges on a state if there is no derivation starting from it
   Since this is big-step semantics, we can't distinguish this from being stuck -}
_divergesOnₙ_ : ∀ {n} → St n → State n → Set
prog divergesOnₙ s = ∀ {s'} → ¬ ⟨ prog , s ⟩⟱ s'

{- A program is divergent if it diverges on all states -}
Divergentₙ : ∀ {n} → St n → Set
Divergentₙ prog = ∀ {s} → prog divergesOnₙ s

{-
The fun thing about the following proof of divergence is that we implicitly
rely on the finiteness of Agda data. Since we have apparent infinite recursion
in the proof, but all inductive Agda data are finite, this implies that no such
derivation may exist in the first place.
-}

private
  inf-loopₙ : ∀ {n} → Divergentₙ {n} (while tt do skip)
  inf-loopₙ (while-true x skip p₁) = inf-loopₙ p₁
  inf-loopₙ (while-false x) = x

-- Semantic equivalence
_⇔_ : ∀ {a b} → Set a → Set b → Set (a L.⊔ b)
A ⇔ B = (A → B) × (B → A)

SemanticEq : ∀ {n} → St n → St n → Set
SemanticEq pa pb = ∀ {s s'} → ⟨ pa , s ⟩⟱ s' ⇔ ⟨ pb , s ⟩⟱ s'

Semantic⇒ : ∀ {n} → St n → St n → Set
Semantic⇒ pa pb = ∀ {s s'} → ⟨ pa , s ⟩⟱ s' → ⟨ pb , s ⟩⟱ s'

private
  -- "while b do S" is equivalent to "if b then (S , while b do S) else skip"
  prog1 : ∀ {n} _ _ → St n
  prog1 b S = while b do S

  prog2 : ∀ {n} _ _ → St n
  prog2 b S = if b then (S , while b do S) else skip

  progeq : ∀ {n b S} → SemanticEq {n} (prog1 b S) (prog2 b S)
  progeq {n}{b}{S} = to , from
    where
    to : Semantic⇒ (prog1 b S) (prog2 b S)
    to (while-true x p1 p2) = if-true x (p1 , p2)
    to (while-false x) = if-false x skip

    from : Semantic⇒ (prog2 b S) (prog1 b S)
    from (if-true x (p1 , p2)) = while-true x p1 p2
    from (if-false x skip) = while-false x

-- The semantics is deterministic. Not much to comment on.
deterministic :
  ∀ {n}{p : St n}{s s' s''} → ⟨ p , s ⟩⟱ s' → ⟨ p , s ⟩⟱ s'' → s' ≡ s''
deterministic = go where
  go : ∀ {p s s' s''} → ⟨ p , s ⟩⟱ s' → ⟨ p , s ⟩⟱ s'' → s' ≡ s''
  go ass ass = refl
  go skip skip = refl
  go (p1 , p2) (p3 , p4) rewrite go p1 p3 | go p2 p4 = refl
  go (if-true x p1) (if-true x₁ p2) rewrite go p1 p2 = refl
  go (if-true x p1) (if-false x₁ p2) rewrite T→≡true x = ⊥-elim x₁
  go (if-false x p1) (if-true x₁ p2) rewrite T→≡true x₁ = ⊥-elim x
  go (if-false x p1) (if-false x₁ p2) rewrite go p1 p2 = refl
  go (while-true x p1 p2) (while-true x₁ p3 p4) rewrite go p1 p3 | go p2 p4 = refl
  go (while-true x p1 p2) (while-false x₁) rewrite T→≡true x = ⊥-elim x₁
  go (while-false x) (while-true x₁ p2 p3) rewrite T→≡true x₁ = ⊥-elim x
  go (while-false x) (while-false x₁) = refl

{-
Below is a proof that is not contained in the book. I did it to familiarize myself
with the style of proving in this semantics.

It proves that if we have a derivation for a loop, then we can construct a
derivation for a loop that goes on for one more iteration, because it has
a higher bound in the condition.

However, if we start out with a loop index that is already greater then the
loop bound, we get divergence. But just having a derivation as hypothesis
rules out divergence! We can show this to Agda by proving the divergence in that
case and getting a contradiction.
-}

private
  loop : St 2
  loop =
    while not (eq (var (# 0)) (var (# 1))) do
      (# 0 := add (lit 1) (var (# 0)))

  once-more :
    ∀ { i₀ lim₀ i₁} →
      ⟨ loop , i₀ ∷ lim₀     ∷ [] ⟩⟱ (i₁     ∷ lim₀     ∷ [])
    → ⟨ loop , i₀ ∷ suc lim₀ ∷ [] ⟩⟱ (1 + i₁ ∷ suc lim₀ ∷ [])

  once-more {i₀}{lim₀} p with cmp i₀ lim₀
  once-more (while-true x₁ ass p₁) | LT x =
    while-true (¬A→FalseA $ a<b⟶a≢sb _ _ x) ass (once-more p₁)

  once-more (while-false x₁) | LT x
    rewrite TrueA→A $ F-not-elim x₁
    = ⊥-elim (a≮a _ x)

  once-more (while-true x p p₁) | EQ refl =
    ⊥-elim (FalseA→¬A x refl)

  once-more (while-false x) | EQ refl =
    while-true (¬A→FalseA $ a≢sa _) ass (while-false (F-not-add $ A→TrueA refl))

  once-more p | GT x =
    ⊥-elim (diverges x p)
    where
    diverges : ∀ {i₀ lim₀} → lim₀ < i₀ → loop divergesOnₙ (i₀ ∷ lim₀ ∷ [])
    diverges p1 (while-true x ass p3) = diverges (<-weakenr1 _ _ p1) p3
    diverges p1 (while-false x) rewrite TrueA→A $ F-not-elim x = a≮a _ p1

{-
Correctness of a factorial program.

This task made me ponder the nature of meta- and object languages a bit.

Our job here is to prove that the factorial program computes a factorial. But in order to
be able to state this property, we had to define the notion of factorial in Agda. But this
Agda ⟦fac⟧ function is already executable! Luckily for us, Agda and Coq and co. already
have computational meaning. So if our goal is to simply have a correct factorial program,
then we should just write it in Agda or Coq (although neither supports software development
in an acceptable manner, unfortunately).

Some languages are just better as metalanguages, but if those metalanguages are also
satisfactory as object languages then we might make do with just a single
language, instead of multiple languages and multiple semantics.

Turning back to the actual proof, note that unlike the manual factorial proof in
Chapter 6.1 of the book, this one looks pretty neat and it's also concise.
It's also structurally similar to the program itself.
-}

module Fac where

  ⟦fac⟧ : ℕ → ℕ
  ⟦fac⟧ zero    = 1
  ⟦fac⟧ (suc n) = suc n * ⟦fac⟧ n

  fac-loop : St 3
  fac-loop =
    while lt (var (# 1)) (var (# 0)) do
        (# 1 := add (lit 1) (var (# 1)) ,
         # 2 := mul (var (# 1)) (var (# 2)) )

  fac : St 3
  fac =
    # 1 := lit 0 ,
    # 2 := lit 1 ,
    fac-loop

  fac-loop-ok :
    ∀ d i
    → ⟨ fac-loop , d + i ∷ i ∷ ⟦fac⟧ i ∷ [] ⟩⟱ (d + i ∷ d + i ∷ ⟦fac⟧ (d + i) ∷ [])
  fac-loop-ok zero i = while-false (¬A→FalseA $ a≮a i )
  fac-loop-ok (suc d) i with fac-loop-ok d (suc i)
  ... | next rewrite +-suc d i = while-true (A→TrueA $ a<sb+a i d) (ass , ass) next

  fac-ok :
    ∀ n {i acc} → ⟨ fac , n ∷ i ∷ acc ∷ [] ⟩⟱ (n ∷ n ∷ ⟦fac⟧ n ∷ [])
  fac-ok n with fac-loop-ok n 0
  ... | loop-ok rewrite +-comm n 0 = ass , ass , loop-ok


open import Nat
open import Prelude
open import List
open import judgemental-erase
open import statics-checks
open import statics-core

module constructability where
  -- we construct expressions and types by induction on their
  -- structure. for each sub term, we call the relevant theorem, then
  -- assemble the results with carefully chosen lists of actions that allow
  -- us to call the appropriate zipper lemmas and maintain well-typedness
  -- at every stage of the contruction.
  --
  -- the proof term at each stage except subsumption is, morally, just the
  -- mapping of the fragment of the action semantics used by the constructs
  -- in the list in the current formation context into the list monoid.

  -- if the name of the given hole is irrelevant
  irr-hole : Nat
  irr-hole = 0

  -- construction of types
  construct-type : (t : htyp) → Σ[ L ∈ List action ] runtype (▹ ⦇-⦈ ◃) L (▹ t ◃)
  construct-type num  = [ construct num ] , DoType TMConNum DoRefl
  construct-type ⦇-⦈ = [ del irr-hole ] , DoType TMDel DoRefl
  construct-type (t1 ==> t2) with construct-type t1 | construct-type t2
  ... | (l1 , ih1) | (l2 , ih2) = l1 ++ construct arrow :: l2 ++ [ move parent ] ,
                                  runtype++ ih1
                                   (DoType TMConArrow
                                     (runtype++ (ziplem-tmarr2 ih2)
                                       (DoType TMArrParent2 DoRefl)))
  construct-type (t1 ⊕ t2) with construct-type t1 | construct-type t2
  ... | (l1 , ih1) | (l2 , ih2) = l1 ++ construct sum :: l2 ++ [ move parent ] ,
                                  runtype++ ih1
                                    (DoType TMConPlus
                                       (runtype++ (ziplem-tmplus2 ih2)
                                         (DoType TMPlusParent2 DoRefl)))
  construct-type (t1 ⊠ t2) with construct-type t1 | construct-type t2
  ... | (l1 , ih1) | (l2 , ih2) = l1 ++ construct prod :: l2 ++ [ move parent ] ,
                                  runtype++ ih1
                                    (DoType TMConProd
                                      (runtype++ (ziplem-tmprod2 ih2)
                                        (DoType TMProdParent2 DoRefl)))
  mutual
    -- construction of expressions in synthetic positions
    construct-synth : {Γ : tctx} {u : Nat} {t : htyp} {e : hexp} →
                      (Γ ⊢ e => t) →
                      Σ[ L ∈ List action ]
                        runsynth Γ ▹ ⦇-⦈[ u ] ◃ ⦇-⦈ L ▹ e ◃ t
      -- the three base cases
    construct-synth (SVar x) = [ construct (var _ irr-hole) ] , DoSynth (SAConVar x) DoRefl
    construct-synth SNum = [ construct (numlit _ irr-hole) ] , DoSynth SAConNumlit DoRefl
    construct-synth SEHole = [ del _ ] , DoSynth SADel DoRefl

      -- the inductive cases
    construct-synth (SPlus e1 e2 ) with construct-ana e1 | construct-ana e2
    ... | (l1 , ih1) | (l2 , ih2) =
      construct (plus irr-hole irr-hole) :: (l2 ++ move parent ::
         move (child 1) :: (l1 ++ [ move parent ])) ,
      DoSynth (SAConPlus1 TCHole2)
       (runsynth++ (ziplem-plus2 ih2)
        (DoSynth (SAMove EMPlusParent2)
         (DoSynth (SAMove EMPlusChild1)
          (runsynth++ (ziplem-plus1 ih1)
           (DoSynth (SAMove EMPlusParent1) DoRefl)))))

    construct-synth {t = t} (SAsc x) with construct-type t | construct-ana x
    ... | (l1 , ih1) | (l2 , ih2) =
      construct asc :: (l1 ++ move parent :: move (child 1) :: (l2 ++ [ move parent ])) ,
      DoSynth SAConAsc
       (runsynth++ (ziplem-asc2 ETTop ETTop ih1)
        (DoSynth (SAMove EMAscParent2)
         (DoSynth (SAMove EMAscChild1)
          (runsynth++ (ziplem-asc1 ih2)
           (DoSynth (SAMove EMAscParent1) DoRefl)))))

    construct-synth {t = t1 ==> t2} (SLam x wt) with construct-type t1 | construct-synth wt
    ... | l1 , ih1 | l2 , ih2 =
      construct (lam _ irr-hole irr-hole) ::
        (l1 ++ (move parent :: move (child 2) :: (l2 ++ [ move parent ]))) ,
      DoSynth (SAConLam x)
       (runsynth++ (ziplem-halflam1 x ETTop (rel◆t _) ih1)
        (DoSynth (SAMove EMHalfLamParent1)
         (DoSynth (SAMove EMHalfLamChild2)
          (runsynth++ (ziplem-halflam2 x EETop SEHole ih2)
           (DoSynth (SAMove EMHalfLamParent2) DoRefl)))))

    construct-synth (SAp e1 m e2) with construct-synth e1 | construct-ana e2
    ... | l1 , ih1 | l2 , ih2 =
      l1 ++ construct (ap irr-hole irr-hole) :: (l2 ++ [ move parent ]) ,
      runsynth++ ih1
       (DoSynth (SAConApArr m)
        (runsynth++ (ziplem-ap2 e1 m ih2)
         (DoSynth (SAMove EMApParent2) DoRefl)))

    construct-synth (SNEHole {u = u} wt) with construct-synth wt
    ... | l , ih = l ++ construct (nehole u) :: move parent :: [] ,
                   runsynth++ ih
                    (DoSynth SAConNEHole
                     (DoSynth (SAMove EMNEHoleParent) DoRefl))

    construct-synth (SPair e1 e2) with construct-synth e1 | construct-synth e2
    ... | l1 , ih1 | l2 , ih2 =
      construct (pair irr-hole irr-hole) :: (l1 ++ move parent :: move (child 2)
        :: l2 ++ [ move parent ]) ,
      DoSynth SAConPair
       (runsynth++ (ziplem-pair1 EETop SEHole ih1 SEHole)
        (DoSynth (SAMove EMPairParent1)
         (DoSynth (SAMove EMPairChild2)
          (runsynth++ (ziplem-pair2 e1 EETop SEHole ih2)
           (DoSynth (SAMove EMPairParent2) DoRefl)))))

    construct-synth (SFst e pr) with construct-synth e
    ... | l , ih = l ++ [ construct (fst irr-hole) ] ,
                   runsynth++ ih (DoSynth (SAConFst1 pr) DoRefl)

    construct-synth (SSnd e pr) with construct-synth e
    ... | l , ih = l ++ [ construct (snd irr-hole) ] ,
                   runsynth++ ih (DoSynth (SAConSnd1 pr) DoRefl)

    -- construction of expressions in analytic positions
    construct-ana : {Γ : tctx} {u : Nat} {t : htyp} {e : hexp} →
                    (Γ ⊢ e <= t) →
                    Σ[ L ∈ List action ]
                      runana Γ ▹ ⦇-⦈[ u ] ◃ L ▹ e ◃ t
    construct-ana (ASubsume x c) with construct-synth x
    ... | l , ih = construct (nehole irr-hole) :: l ++ (move parent :: finish :: []) ,
                   DoAna (AASubsume EETop SEHole SAConNEHole TCHole1)
                    (runana++  (ziplem-nehole-b SEHole c ih)
                     (DoAna (AAMove EMNEHoleParent)
                      (DoAna (AAFinish (ASubsume x c)) DoRefl)))

    construct-ana (ALam a m e) with construct-ana e
    ... | l , ih = construct (lam _ irr-hole irr-hole) :: (l ++ [ move parent ]) ,
                   DoAna (AAConLam1 a m)
                    (runana++ (ziplem-lam a m ih)
                     (DoAna (AAMove EMLamParent) DoRefl))

    construct-ana (AInl m wt) with construct-ana wt
    ... | l , ih = construct (inl irr-hole irr-hole) :: l ++ [ move parent ]  ,
                   DoAna (AAConInl1 m)
                    (runana++ (ziplem-inl m ih)
                     (DoAna (AAMove EMInlParent) DoRefl))

    construct-ana (AInr m wt) with construct-ana wt
    ... | l , ih = construct (inr irr-hole irr-hole) :: l ++ [ move parent ]  ,
                   DoAna (AAConInr1 m)
                    (runana++ (ziplem-inr m ih)
                     (DoAna (AAMove EMInrParent) DoRefl))

    construct-ana (ACase {x = x} {y = y} x# y# m wt0 wt1 wt2)
      with construct-synth wt0
         | construct-ana wt1
         | construct-ana wt2
    ... | l0 , ih0 | l1 , ih1 | l2 , ih2 =
      construct (case x y irr-hole irr-hole irr-hole) :: construct (nehole irr-hole) ::
      l0 ++ (move parent :: finish :: move parent :: move (child 2) ::
      l1 ++ (move parent :: move (child 3) ::
      l2 ++ [ move parent ])) ,
      DoAna (AAConCase x# y#)
       (DoAna (AAZipCase1 x# y# EETop SEHole SAConNEHole MSHole
              (ASubsume SEHole TCHole1) (ASubsume SEHole TCHole1))
        (runana++ (ziplem-case1b x# y# EETop SEHole ih0)
         (DoAna (AAZipCase1 x# y# (EENEHole EETop)
                (SNEHole wt0) (SAMove EMNEHoleParent) MSHole (ASubsume SEHole TCHole1)
                (ASubsume SEHole TCHole1))
          (DoAna (AAZipCase1 x# y# EETop (SNEHole wt0) (SAFinish wt0) m
                 (ASubsume SEHole TCHole1) (ASubsume SEHole TCHole1))
           (DoAna (AAMove EMCaseParent1)
            (DoAna (AAMove EMCaseChild2)
             (runana++ (ziplem-case2 x# y# wt0 (ASubsume SEHole TCHole1) m ih1)
              (DoAna (AAMove EMCaseParent2)
               (DoAna (AAMove EMCaseChild3)
                (runana++ (ziplem-case3 x# y# wt0 wt1 m ih2)
                 (DoAna (AAMove EMCaseParent3) DoRefl)))))))))))


module Dave.Extensionality where
    open import Dave.Equality

    postulate
        extensionality : ∀ {A B : Set} {f g : A → B}
            → (∀ (x : A) → f x ≡ g x)
            → f ≡ g

    postulate
        ∀-extensionality : ∀ {A : Set} {B : A → Set} {f g : ∀(x : A) → B x}
            → (∀ (x : A) → f x ≡ g x)
            → f ≡ g


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed M-types (the dual of indexed W-types aka Petersson-Synek
-- trees).
------------------------------------------------------------------------

module Data.M.Indexed where

open import Level
open import Coinduction
open import Data.Product
open import Data.Container.Indexed.Core
open import Function
open import Relation.Unary

-- The family of indexed M-types.

module _ {ℓ c r} {O : Set ℓ} (C : Container O O c r) where

  data M (o : O) : Set (ℓ ⊔ c ⊔ r) where
    inf : ⟦ C ⟧ (∞ ∘ M) o → M o

  open Container C

  -- Projections.

  head : M ⊆ Command
  head (inf (c , _)) = c

  tail : ∀ {o} (m : M o) (r : Response (head m)) → M (next (head m) r)
  tail (inf (_ , k)) r = ♭ (k r)

  force : M ⊆ ⟦ C ⟧ M
  force (inf (c , k)) = c , λ r → ♭ (k r)

  -- Coiteration.

  coit : ∀ {ℓ} {X : Pred O ℓ} → X ⊆ ⟦ C ⟧ X → X ⊆ M
  coit ψ x = inf (proj₁ cs , λ r → ♯ coit ψ (proj₂ cs r))
    where
    cs = ψ x


{-# OPTIONS --without-K --safe #-}

module Categories.Category.Instance.Monoidals where

open import Level

open import Categories.Category
open import Categories.Category.Helper
open import Categories.Category.Monoidal
open import Categories.Functor.Monoidal
open import Categories.Functor.Monoidal.Properties
open import Categories.NaturalTransformation.NaturalIsomorphism.Monoidal

module _ o ℓ e where

  Monoidals : Category (suc (o ⊔ ℓ ⊔ e)) (o ⊔ ℓ ⊔ e) (o ⊔ ℓ ⊔ e)
  Monoidals = categoryHelper record
    { Obj       = MonoidalCategory o ℓ e
    ; _⇒_       = MonoidalFunctor
    ; _≈_       = Lax._≃_
    ; id        = idF-Monoidal _
    ; _∘_       = ∘-Monoidal
    -- NOTE: these η-expanded versions typecheck much faster...
    ; assoc     = λ {_ _ _ _ F G H} → associator {F = F} {G} {H}
    ; identityˡ = λ {_ _ F} → unitorˡ {F = F}
    ; identityʳ = λ {_ _ F} → unitorʳ {F = F}
    ; equiv     = isEquivalence
    ; ∘-resp-≈  = _ⓘₕ_
    }
    where open Lax

  StrongMonoidals : Category (suc (o ⊔ ℓ ⊔ e)) (o ⊔ ℓ ⊔ e) (o ⊔ ℓ ⊔ e)
  StrongMonoidals = categoryHelper record
    { Obj       = MonoidalCategory o ℓ e
    ; _⇒_       = StrongMonoidalFunctor
    ; _≈_       = Strong._≃_
    ; id        = idF-StrongMonoidal _
    ; _∘_       = ∘-StrongMonoidal
    -- NOTE: these η-expanded versions typecheck much faster...
    ; assoc     = λ {_ _ _ _ F G H} → associator {F = F} {G} {H}
    ; identityˡ = λ {_ _ F} → unitorˡ {F = F}
    ; identityʳ = λ {_ _ F} → unitorʳ {F = F}
    ; equiv     = isEquivalence
    ; ∘-resp-≈  = _ⓘₕ_
    }
    where open Strong


{-# OPTIONS --cubical #-}
module ExerciseSession2 where

open import Part1
open import Part2
open import Part3
open import Part4

    -- (* Construct a point if isContr A → Π (x y : A) . isContr (x = y) *)

isProp→isSet : isProp A → isSet A
isProp→isSet h a b p q j i =
  hcomp (λ k → λ { (i = i0) → h a a k
                 ; (i = i1) → h a b k
                 ; (j = i0) → h a (p i) k
                 ; (j = i1) → h a (q i) k }) a

foo : isProp A → isProp' A
foo h = λ x y → (h x y) , λ q → isProp→isSet h _ _ (h x y) q

-- hProp : {ℓ : Level} → Type (ℓ-suc ℓ)
-- hProp {ℓ = ℓ} = Σ[ A ∈ Type ℓ ] isProp A

-- foo : isContr (Σ[ A ∈ hProp {ℓ = ℓ} ] (fst A))
-- foo = ({!!} , {!!}) , {!!}

-- Σ≡Prop : ((x : A) → isProp (B x)) → {u v : Σ A B}
--        → (p : u .fst ≡ v .fst) → u ≡ v


{-# OPTIONS --with-K -vtc.lhs.unify:50 #-}

open import Agda.Primitive        using (Setω)
open import Agda.Builtin.Equality using (_≡_; refl)

-- change `Set` to `Setω` breaks `seq`
data RecD  (I : Set) : Setω where
  ι : (i : I) → RecD I

data RecO {I J : Set} (e : I → J) : RecD I → RecD J → Setω where
  ι : (i : I) (j : J) (eq : e i ≡ j) → RecO e (ι i) (ι j)

seq : {I J K : Set} {e : I → J} {f : J → K} {D : RecD I} {E : RecD J} {F : RecD K}
  → RecO f E F → RecO e D E
  → RecO (λ i → f (e i)) D F
seq (ι _ _ refl) (ι _ _ refl) = ι _ _ refl


{-# OPTIONS --type-in-type #-}
module chu.lens where
open import prelude
open import functors
open import chu
open import poly.core

→∫ : Chu → ∫
→∫ (A⁺ , A⁻ ! Ω) = A⁺ , λ a⁺ → ∃ (Ω a⁺)

→Lens : {A B : Chu} → Chu[ A , B ] → ∫[ →∫ A , →∫ B ]
→Lens (f ↔ fᵗ ! †)  a⁺ = f a⁺ , λ (b⁻ , fa⁺Ωb⁻) → fᵗ b⁻ , subst id († a⁺ b⁻) fa⁺Ωb⁻

module _ {A B C : Chu}
         (F@(f ↔ fᵗ ! _†₁_) : Chu[ A , B ])
         (G@(g ↔ gᵗ ! _†₂_) : Chu[ B , C ]) where

    comp₂ : ∀ a⁺ → π₂  (→Lens (F ▸       G) a⁺)
                 ≡ π₂ ((→Lens  F ▸ →Lens G) a⁺)
    comp₂ a⁺ = extensionality λ ( c⁻ , gfaΩc ) → (λ x → (fᵗ ∘ gᵗ) c⁻ , x) ⟨$⟩
               subst⋯ id (f a⁺ †₂ c⁻) (a⁺ †₁ gᵗ c⁻) gfaΩc

    comp∀ : ∀ a⁺ → →Lens (F ▸ G) a⁺ ≡ (→Lens F ▸ →Lens G) a⁺
    comp∀ a⁺ rewrite comp₂ a⁺ = refl

instance
    open Chu[_,_]
    chu-lens-functor : Functor →∫
    chu-lens-functor = φ: →Lens
                       𝒾: refl
                       ▸: λ F G → extensionality (comp∀ F G)


{-# OPTIONS --without-K --safe #-}

open import Algebra

module Data.FingerTree.Measures
  {r m}
  (ℳ : Monoid r m)
  where

open import Level using (_⊔_)

open Monoid ℳ renaming (Carrier to 𝓡)
open import Data.List as List using (List; _∷_; [])
open import Data.Product
open import Function

-- | A measure.
record σ {a} (Σ : Set a) : Set (a ⊔ r) where field μ : Σ → 𝓡
open σ ⦃ ... ⦄
{-# DISPLAY σ.μ _ = μ #-}

instance
  σ-List : ∀ {a} {Σ : Set a} → ⦃ _ : σ Σ ⦄ → σ (List Σ)
  μ ⦃ σ-List ⦄ = List.foldr (_∙_ ∘ μ) ε

-- A "fiber" (I think) from the μ function.
--
-- μ⟨ Σ ⟩≈ 𝓂 means "There exists a Σ such that μ Σ ≈ 𝓂"
infixl 2 _⇑[_]
record μ⟨_⟩≈_ {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ (𝓂 : 𝓡) : Set (a ⊔ r ⊔ m) where
  constructor _⇑[_]
  field
    𝓢 : Σ
    .𝒻 : μ 𝓢 ≈ 𝓂
open μ⟨_⟩≈_ public

-- Construct a measured value without any transformations of the measure.
infixl 2 _⇑
_⇑ : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ (𝓢 : Σ) → μ⟨ Σ ⟩≈ μ 𝓢
𝓢 (x ⇑) = x
𝒻 (x ⇑) = refl
{-# INLINE _⇑ #-}

-- These combinators allow for a kind of easoning syntax over the measures.
-- The first is used like so:
--
--   xs ≈[ assoc _ _ _ ]
--
-- Which will have the type:
--
--   μ⟨ Σ ⟩≈ x ∙ y ∙ z → μ⟨ Σ ⟩≈ (x ∙ y) ∙ z
--
-- The second does the same:
--
--   xs ≈[ assoc _ _ _ ]′
--
-- However, when used in a chain, it typechecks after the ones used to its
-- left. This means you can call the solver on the left.
--
--   xs ≈[ ℳ ↯ ] ≈[ assoc _ _ _ ]′
infixl 2 _≈[_] ≈-rev
_≈[_] : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ {x : 𝓡} → μ⟨ Σ ⟩≈ x → ∀ {y} → .(x ≈ y) → μ⟨ Σ ⟩≈ y
𝓢 (xs ≈[ y≈z ]) = 𝓢 xs
𝒻 (xs ≈[ y≈z ]) = trans (𝒻 xs) y≈z
{-# INLINE _≈[_] #-}

≈-rev : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ {x : 𝓡} → ∀ {y} → .(x ≈ y) → μ⟨ Σ ⟩≈ x → μ⟨ Σ ⟩≈ y
𝓢 (≈-rev y≈z xs) = 𝓢 xs
𝒻 (≈-rev y≈z xs) = trans (𝒻 xs) y≈z
{-# INLINE ≈-rev #-}

syntax ≈-rev y≈z x↦y = x↦y ≈[ y≈z ]′

infixr 2 ≈-right
≈-right : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ {x : 𝓡} → μ⟨ Σ ⟩≈ x → ∀ {y} → .(x ≈ y) → μ⟨ Σ ⟩≈ y
≈-right (x ⇑[ x≈y ]) y≈z = x ⇑[ trans x≈y y≈z ]

syntax ≈-right x x≈ = [ x≈ ]≈ x

infixr 1 _↤_
-- A memoized application of μ
record ⟪_⟫ {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ : Set (a ⊔ r ⊔ m) where
  constructor _↤_
  field
    𝔐 : 𝓡
    𝓕 : μ⟨ Σ ⟩≈ 𝔐
open ⟪_⟫ public

-- Construct the memoized version
⟪_⇓⟫ : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → Σ → ⟪ Σ ⟫
𝔐 ⟪ x ⇓⟫ = μ x
𝓕 ⟪ x ⇓⟫ = x ⇑

instance
  σ-⟪⟫ : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → σ ⟪ Σ ⟫
  μ ⦃ σ-⟪⟫ ⦄ = 𝔐

open import Algebra.FunctionProperties _≈_

-- This section allows us to use the do-notation to clean up proofs.
-- First, we construct arguments:
infixl 2 arg-syntax
record Arg {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ (𝓂 : 𝓡) (f : 𝓡 → 𝓡) : Set (m ⊔ r ⊔ a) where
  constructor arg-syntax
  field
    .⟨f⟩ : Congruent₁ f
    arg : μ⟨ Σ ⟩≈ 𝓂
open Arg

syntax arg-syntax (λ sz → e₁) xs = xs [ e₁ ⟿ sz ]
-- This syntax is meant to be used like so:
--
--   do x ← xs [ a ∙> (s <∙ b) ⟿ s ]
--
-- And it means "the size of the variable I'm binding here will be stored in this
-- part of the expression". See, for example, the listToTree function:
--
--   listToTree [] = empty ⇑
--   listToTree (x ∷ xs) = [ ℳ ↯ ]≈ do
--     ys ← listToTree xs [ μ x ∙> s ⟿ s ]
--     x ◂ ys
--
infixl 1 _>>=_
_>>=_ : ∀ {a b} {Σ₁ : Set a} {Σ₂ : Set b} ⦃ _ : σ Σ₁ ⦄ ⦃ _ : σ Σ₂ ⦄ {𝓂 f}
      → Arg Σ₁ 𝓂 f
      → ((x : Σ₁) → .⦃ x≈ : μ x ≈ 𝓂 ⦄ → μ⟨ Σ₂ ⟩≈ f (μ x))
      → μ⟨ Σ₂ ⟩≈ f 𝓂
arg-syntax cng xs >>= k = k (𝓢 xs) ⦃ 𝒻 xs ⦄ ≈[ cng (𝒻 xs) ]
{-# INLINE _>>=_ #-}

-- Inside the lambda generated by do notation, we can only pass one argument.
-- So, to provide the proof (if needed)
_≈?_ : ∀ x y → ⦃ x≈y : x ≈ y ⦄ → x ≈ y
_≈?_ _ _ ⦃ x≈y ⦄ = x≈y


------------------------------------------------------------------------
-- The Agda standard library
--
-- Reflection utilities for Fin
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.Fin.Reflection where

open import Data.Nat.Base as ℕ hiding (module ℕ)
open import Data.Fin.Base as Fin hiding (module Fin)
open import Data.List.Base
open import Reflection.Term
open import Reflection.Argument

------------------------------------------------------------------------
-- Term

toTerm : ∀ {n} → Fin n → Term
toTerm zero    = con (quote Fin.zero) (1 ⋯⟅∷⟆ [])
toTerm (suc i) = con (quote Fin.suc)  (1 ⋯⟅∷⟆ toTerm i ⟨∷⟩ [])


{-# OPTIONS --without-K #-}

module Pi0Examples where

open import PiU using (U; ZERO; ONE; PLUS; TIMES)
open import PiLevel0
  using (_⟷_;
         unite₊l; uniti₊l; unite₊r; uniti₊r; swap₊; assocl₊; assocr₊;
         unite⋆l; uniti⋆l; unite⋆r; uniti⋆r; swap⋆; assocl⋆; assocr⋆;
         absorbr; absorbl; factorzr; factorzl;
         dist; factor; distl; factorl;
         id⟷; _◎_; _⊕_; _⊗_)

------------------------------------------------------------------------------
-- Example circuits on booleans

BOOL : U
BOOL  = PLUS ONE ONE

BOOL² : U
BOOL² = TIMES BOOL BOOL

-- Nicer syntax that shows intermediate values instead of the above
-- point-free notation of permutations

infixr 2  _⟷⟨_⟩_
infix  3  _□

_⟷⟨_⟩_ : (t₁ : U) {t₂ : U} {t₃ : U} →
          (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
_ ⟷⟨ α ⟩ β = α ◎ β

_□ : (t : U) → {t : U} → (t ⟷ t)
_□ t = id⟷

foldBool unfoldBool : BOOL ⟷ BOOL
foldBool = id⟷
unfoldBool = id⟷

------------------------------------------------------------------------------
-- Many ways of negating a BOOL.

NOT : BOOL ⟷ BOOL
NOT = unfoldBool ◎ swap₊ ◎ foldBool
-- spec: (false , true) ∷ (true , false) ∷ []

NEG1 NEG2 NEG3 NEG4 NEG5 : BOOL ⟷ BOOL
NEG1 = unfoldBool ◎ swap₊ ◎ foldBool
-- spec: (false , true) ∷ (true , false) ∷ []
NEG2 = id⟷ ◎ NOT
-- spec: (false , true) ∷ (true , false) ∷ []
NEG3 = NOT ◎ NOT ◎ NOT
-- spec: (false , true) ∷ (true , false) ∷ []
NEG4 = NOT ◎ id⟷
-- spec: (false , true) ∷ (true , false) ∷ []
NEG5 = uniti⋆l ◎ swap⋆ ◎ (NOT ⊗ id⟷) ◎ swap⋆ ◎ unite⋆l
-- spec: (false , true) ∷ (true , false) ∷ []
NEG6 = uniti⋆r ◎ (NOT ⊗ id⟷) ◎ unite⋆r -- same as above, but shorter

-- CNOT

CNOT : BOOL² ⟷ BOOL²
CNOT = TIMES BOOL BOOL
         ⟷⟨ unfoldBool ⊗ id⟷ ⟩
       TIMES (PLUS x y) BOOL
         ⟷⟨ dist ⟩
       PLUS (TIMES x BOOL) (TIMES y BOOL)
         ⟷⟨ id⟷ ⊕ (id⟷ ⊗ NOT) ⟩
       PLUS (TIMES x BOOL) (TIMES y BOOL)
         ⟷⟨ factor ⟩
       TIMES (PLUS x y) BOOL
         ⟷⟨ foldBool ⊗ id⟷ ⟩
       TIMES BOOL BOOL □
  where x = ONE; y = ONE

-- spec:
-- ((false , false) , false , false) ∷
-- ((false , true)  , false , true)  ∷
-- ((true  , false) , true  , true)  ∷
-- ((true  , true)  , true  , false) ∷ []

-- TOFFOLI

TOFFOLI : TIMES BOOL BOOL² ⟷ TIMES BOOL BOOL²
TOFFOLI = TIMES BOOL BOOL²
            ⟷⟨ unfoldBool ⊗ id⟷ ⟩
          TIMES (PLUS x y) BOOL²
            ⟷⟨ dist ⟩
          PLUS (TIMES x BOOL²) (TIMES y BOOL²)
            ⟷⟨ id⟷ ⊕ (id⟷ ⊗ CNOT) ⟩
          PLUS (TIMES x BOOL²) (TIMES y BOOL²)
            ⟷⟨ factor ⟩
          TIMES (PLUS x y) BOOL²
            ⟷⟨ foldBool ⊗ id⟷ ⟩
         TIMES BOOL BOOL² □
  where x = ONE; y = ONE

-- spec:
-- ((false , false , false) , false , false , false) ∷
-- ((false , false , true)  , false , false , true)  ∷
-- ((false , true  , false) , false , true  , false) ∷
-- ((false , true  , true)  , false , true  , true)  ∷
-- ((true  , false , false) , true  , false , false) ∷
-- ((true  , false , true)  , true  , false , true)  ∷
-- ((true  , true  , false) , true  , true  , true)  ∷
-- ((true  , true  , true)  , true  , true  , false) ∷ []

-- Swaps for the type 1+(1+1)
-- We have three values in the type 1+(1+1)
-- Let's call them a, b, and c
-- There 6 permutations. Using the swaps below we can express every permutation:
-- a b c id⟷
-- a c b SWAP23
-- b a c SWAP12
-- b c a ROTL
-- c a b ROTR
-- c b a SWAP13

SWAP12 SWAP23 SWAP13 ROTL ROTR :
  PLUS ONE (PLUS ONE ONE) ⟷ PLUS ONE (PLUS ONE ONE)
SWAP12 = assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊
-- spec:
-- (inj₁ tt        , inj₂ (inj₁ tt)) ∷
-- (inj₂ (inj₁ tt) , inj₁ tt)        ∷
-- (inj₂ (inj₂ tt) , inj₂ (inj₂ tt)) ∷ []
SWAP23 = id⟷ ⊕ swap₊
-- spec:
-- (inj₁ tt        , inj₁ tt)        ∷
-- (inj₂ (inj₁ tt) , inj₂ (inj₂ tt)) ∷
-- (inj₂ (inj₂ tt) , inj₂ (inj₁ tt)) ∷ []
SWAP13 = SWAP23 ◎ SWAP12 ◎ SWAP23
-- spec:
-- (inj₁ tt        , inj₂ (inj₂ tt)) ∷
-- (inj₂ (inj₁ tt) , inj₂ (inj₁ tt)) ∷
-- (inj₂ (inj₂ tt) , inj₁ tt)        ∷ []
ROTR   = SWAP12 ◎ SWAP23
-- spec:
-- (inj₁ tt        , inj₂ (inj₂ tt)) ∷
-- (inj₂ (inj₁ tt) , inj₁ tt)        ∷
-- (inj₂ (inj₂ tt) , inj₂ (inj₁ tt)) ∷ []
ROTL   = SWAP13 ◎ SWAP23
-- spec:
-- (inj₁ tt        , inj₂ (inj₁ tt)) ∷
-- (inj₂ (inj₁ tt) , inj₂ (inj₂ tt)) ∷
-- (inj₂ (inj₂ tt) , inj₁ tt)        ∷ []

-- The Peres gate is a universal gate: it takes three inputs a, b, and c, and
-- produces a, a xor b, (a and b) xor c

PERES : TIMES (TIMES BOOL BOOL) BOOL ⟷ TIMES (TIMES BOOL BOOL) BOOL
PERES = (id⟷ ⊗ NOT) ◎ assocr⋆ ◎ (id⟷ ⊗ swap⋆) ◎
        TOFFOLI ◎
        (id⟷ ⊗ (NOT ⊗ id⟷)) ◎
        TOFFOLI ◎
        (id⟷ ⊗ swap⋆) ◎ (id⟷ ⊗ (NOT ⊗ id⟷)) ◎
        TOFFOLI ◎
        (id⟷ ⊗ (NOT ⊗ id⟷)) ◎ assocl⋆
-- spec:
-- (((false , false) , false) , (false , false) , false) ∷
-- (((false , false) , true)  , (false , false) , true)  ∷
-- (((false , true)  , false) , (false , true)  , false) ∷
-- (((false , true)  , true)  , (false , true)  , true)  ∷
-- (((true  , false) , false) , (true  , true)  , false) ∷
-- (((true  , false) , true)  , (true  , true)  , true)  ∷
-- (((true  , true)  , false) , (true  , false) , true)  ∷
-- (((true  , true)  , true)  , (true  , false) , false) ∷ []

-- A reversible full adder: See http://arxiv.org/pdf/1008.3533.pdf
-- Input: (z, ((n1, n2), cin)))
-- Output (g1, (g2, (sum, cout)))
-- where sum = n1 xor n2 xor cin
-- and cout = ((n1 xor n2) and cin) xor (n1 and n2) xor z
FULLADDER : TIMES BOOL (TIMES (TIMES BOOL BOOL) BOOL) ⟷
            TIMES BOOL (TIMES BOOL (TIMES BOOL BOOL))
FULLADDER =
  -- (z,((n1,n2),cin))
  swap⋆ ◎
  -- (((n1,n2),cin),z)
  (swap⋆ ⊗ id⟷) ◎
  -- ((cin,(n1,n2)),z)
  assocr⋆ ◎
  -- (cin,((n1,n2),z))
  swap⋆ ◎
  -- (((n1,n2),z),cin)
  (PERES ⊗ id⟷) ◎
  -- (((n1,n1 xor n2),(n1 and n2) xor z),cin)
  assocr⋆ ◎
  -- ((n1,n1 xor n2),((n1 and n2) xor z,cin))
  (id⟷ ⊗ swap⋆) ◎
  -- ((n1,n1 xor n2),(cin,(n1 and n2) xor z))
  assocr⋆ ◎
  -- (n1,(n1 xor n2,(cin,(n1 and n2) xor z)))
  (id⟷ ⊗ assocl⋆) ◎
  -- (n1,((n1 xor n2,cin),(n1 and n2) xor z))
  (id⟷ ⊗ PERES) ◎
  -- (n1,((n1 xor n2,n1 xor n2 xor cin),
  --      ((n1 xor n2) and cin) xor (n1 and n2) xor z))
  (id⟷ ⊗ assocr⋆)
  -- (n1,(n1 xor n2,
  --      (n1 xor n2 xor cin,((n1 xor n2) and cin) xor (n1 and n2) xor z)))
-- spec:
-- ((false , (false , false) , false) , false , false , false , false) ∷
-- ((false , (false , false) , true)  , false , false , true  , false) ∷
-- ((false , (false , true)  , false) , false , true  , true  , false) ∷
-- ((false , (false , true)  , true)  , false , true  , false , true)  ∷
-- ((false , (true  , false) , false) , true  , true  , true  , false) ∷
-- ((false , (true  , false) , true)  , true  , true  , false , true)  ∷
-- ((false , (true  , true)  , false) , true  , false , false , true)  ∷
-- ((false , (true  , true)  , true)  , true  , false , true  , true)  ∷
-- ((true  , (false , false) , false) , false , false , false , true)  ∷
-- ((true  , (false , false) , true)  , false , false , true  , true)  ∷
-- ((true  , (false , true)  , false) , false , true  , true  , true)  ∷
-- ((true  , (false , true)  , true)  , false , true  , false , false) ∷
-- ((true  , (true  , false) , false) , true  , true  , true  , true)  ∷
-- ((true  , (true  , false) , true)  , true  , true  , false , false) ∷
-- ((true  , (true  , true)  , false) , true  , false , false , false) ∷
-- ((true  , (true  , true)  , true)  , true  , false , true  , false) ∷ []

------------------------------------------------------------------------------
-- Generalized CNOT and TOFFOLI

ttt : {t₁ t₂ t₃ t₄ : U} →
  (TIMES (PLUS t₁ t₂) (PLUS t₃ t₄)) ⟷
  (PLUS (PLUS (PLUS (TIMES t₁ t₃) (TIMES t₂ t₃)) (TIMES t₁ t₄))) (TIMES t₂ t₄)
ttt {t₁} {t₂} {t₃} {t₄} =
  (distl ◎ (dist {t₁} {t₂} {t₃} ⊕ dist {t₁} {t₂} {t₄})) ◎ assocl₊

-- generalized CNOT

gcnot : {A B C : U} →
        (TIMES (PLUS A B) (PLUS C C)) ⟷ (TIMES (PLUS A B) (PLUS C C))
gcnot = dist ◎ (id⟷ ⊕ (id⟷ ⊗ swap₊)) ◎ factor

-- Generalized Toffolli gate.  See what 'arithmetic' it performs.

GToffoli : {A B C D E : U} →
           TIMES (PLUS A B) (TIMES (PLUS C D) (PLUS E E)) ⟷
           TIMES (PLUS A B) (TIMES (PLUS C D) (PLUS E E))
GToffoli = dist ◎ (id⟷ ⊕ (id⟷ ⊗ gcnot)) ◎ factor

------------------------------------------------------------------------------


{-# OPTIONS --warning=error --safe --without-K #-}

open import LogicalFormulae

module Maybe where

data Maybe {a : _} (A : Set a) : Set a where
  no : Maybe A
  yes : A → Maybe A

joinMaybe : {a : _} → {A : Set a} → Maybe (Maybe A) → Maybe A
joinMaybe no = no
joinMaybe (yes s) = s

bindMaybe : {a b : _} → {A : Set a} → {B : Set b} → Maybe A → (A → Maybe B) → Maybe B
bindMaybe no f = no
bindMaybe (yes x) f = f x

applyMaybe : {a b : _} → {A : Set a} → {B : Set b} → Maybe (A → B) → Maybe A → Maybe B
applyMaybe f no = no
applyMaybe no (yes x) = no
applyMaybe (yes f) (yes x) = yes (f x)

yesInjective : {a : _} → {A : Set a} → {x y : A} → (yes x ≡ yes y) → x ≡ y
yesInjective {a} {A} {x} {.x} refl = refl

mapMaybe : {a b : _} → {A : Set a} → {B : Set b} → (f : A → B) → Maybe A → Maybe B
mapMaybe f no = no
mapMaybe f (yes x) = yes (f x)

defaultValue : {a : _} → {A : Set a} → (default : A) → Maybe A → A
defaultValue default no = default
defaultValue default (yes x) = x

noNotYes : {a : _} {A : Set a} {b : A} → (no ≡ yes b) → False
noNotYes ()

mapMaybePreservesNo : {a b : _} {A : Set a} {B : Set b} {f : A → B} {x : Maybe A} → mapMaybe f x ≡ no → x ≡ no
mapMaybePreservesNo {f = f} {no} pr = refl

mapMaybePreservesYes : {a b : _} {A : Set a} {B : Set b} {f : A → B} {x : Maybe A} {y : B} → mapMaybe f x ≡ yes y → Sg A (λ z → (x ≡ yes z) && (f z ≡ y))
mapMaybePreservesYes {f = f} {x} {y} map with x
mapMaybePreservesYes {f = f} {x} {y} map | yes z = z , (refl ,, yesInjective map)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Solver for monoid equalities
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Algebra

module Algebra.Solver.Monoid {m₁ m₂} (M : Monoid m₁ m₂) where

open import Data.Fin as Fin hiding (_≟_)
import Data.Fin.Properties as Fin
open import Data.List.Base hiding (lookup)
import Data.List.Relation.Binary.Equality.DecPropositional as ListEq
open import Data.Maybe as Maybe
  using (Maybe; decToMaybe; From-just; from-just)
open import Data.Nat.Base using (ℕ)
open import Data.Product
open import Data.Vec using (Vec; lookup)
open import Function using (_∘_; _$_)
open import Relation.Binary using (Decidable)

open import Relation.Binary.PropositionalEquality as P using (_≡_)
import Relation.Binary.Reflection
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec

open Monoid M
open import Relation.Binary.Reasoning.Setoid setoid

------------------------------------------------------------------------
-- Monoid expressions

-- There is one constructor for every operation, plus one for
-- variables; there may be at most n variables.

infixr 5 _⊕_

data Expr (n : ℕ) : Set where
  var : Fin n → Expr n
  id  : Expr n
  _⊕_ : Expr n → Expr n → Expr n

-- An environment contains one value for every variable.

Env : ℕ → Set _
Env n = Vec Carrier n

-- The semantics of an expression is a function from an environment to
-- a value.

⟦_⟧ : ∀ {n} → Expr n → Env n → Carrier
⟦ var x   ⟧ ρ = lookup ρ x
⟦ id      ⟧ ρ = ε
⟦ e₁ ⊕ e₂ ⟧ ρ = ⟦ e₁ ⟧ ρ ∙ ⟦ e₂ ⟧ ρ

------------------------------------------------------------------------
-- Normal forms

-- A normal form is a list of variables.

Normal : ℕ → Set
Normal n = List (Fin n)

-- The semantics of a normal form.

⟦_⟧⇓ : ∀ {n} → Normal n → Env n → Carrier
⟦ []     ⟧⇓ ρ = ε
⟦ x ∷ nf ⟧⇓ ρ = lookup ρ x ∙ ⟦ nf ⟧⇓ ρ

-- A normaliser.

normalise : ∀ {n} → Expr n → Normal n
normalise (var x)   = x ∷ []
normalise id        = []
normalise (e₁ ⊕ e₂) = normalise e₁ ++ normalise e₂

-- The normaliser is homomorphic with respect to _++_/_∙_.

homomorphic : ∀ {n} (nf₁ nf₂ : Normal n) (ρ : Env n) →
              ⟦ nf₁ ++ nf₂ ⟧⇓ ρ ≈ (⟦ nf₁ ⟧⇓ ρ ∙ ⟦ nf₂ ⟧⇓ ρ)
homomorphic [] nf₂ ρ = begin
  ⟦ nf₂ ⟧⇓ ρ      ≈⟨ sym $ identityˡ _ ⟩
  ε ∙ ⟦ nf₂ ⟧⇓ ρ  ∎
homomorphic (x ∷ nf₁) nf₂ ρ = begin
  lookup ρ x ∙ ⟦ nf₁ ++ nf₂ ⟧⇓ ρ          ≈⟨ ∙-congˡ (homomorphic nf₁ nf₂ ρ) ⟩
  lookup ρ x ∙ (⟦ nf₁ ⟧⇓ ρ ∙ ⟦ nf₂ ⟧⇓ ρ)  ≈⟨ sym $ assoc _ _ _ ⟩
  lookup ρ x ∙ ⟦ nf₁ ⟧⇓ ρ ∙ ⟦ nf₂ ⟧⇓ ρ    ∎

-- The normaliser preserves the semantics of the expression.

normalise-correct :
  ∀ {n} (e : Expr n) (ρ : Env n) → ⟦ normalise e ⟧⇓ ρ ≈ ⟦ e ⟧ ρ
normalise-correct (var x) ρ = begin
  lookup ρ x ∙ ε  ≈⟨ identityʳ _ ⟩
  lookup ρ x      ∎
normalise-correct id ρ = begin
  ε  ∎
normalise-correct (e₁ ⊕ e₂) ρ = begin
  ⟦ normalise e₁ ++ normalise e₂ ⟧⇓ ρ        ≈⟨ homomorphic (normalise e₁) (normalise e₂) ρ ⟩
  ⟦ normalise e₁ ⟧⇓ ρ ∙ ⟦ normalise e₂ ⟧⇓ ρ  ≈⟨ ∙-cong (normalise-correct e₁ ρ) (normalise-correct e₂ ρ) ⟩
  ⟦ e₁ ⟧ ρ ∙ ⟦ e₂ ⟧ ρ                        ∎

------------------------------------------------------------------------
-- "Tactics"

open module R = Relation.Binary.Reflection
                  setoid var ⟦_⟧ (⟦_⟧⇓ ∘ normalise) normalise-correct
  public using (solve; _⊜_)

-- We can decide if two normal forms are /syntactically/ equal.

infix 5 _≟_

_≟_ : ∀ {n} → Decidable {A = Normal n} _≡_
nf₁ ≟ nf₂ = Dec.map′ ≋⇒≡ ≡⇒≋ (nf₁ ≋? nf₂)
  where open ListEq Fin._≟_

-- We can also give a sound, but not necessarily complete, procedure
-- for determining if two expressions have the same semantics.

prove′ : ∀ {n} (e₁ e₂ : Expr n) → Maybe (∀ ρ → ⟦ e₁ ⟧ ρ ≈ ⟦ e₂ ⟧ ρ)
prove′ e₁ e₂ =
  Maybe.map lemma $ decToMaybe (normalise e₁ ≟ normalise e₂)
  where
  lemma : normalise e₁ ≡ normalise e₂ → ∀ ρ → ⟦ e₁ ⟧ ρ ≈ ⟦ e₂ ⟧ ρ
  lemma eq ρ =
    R.prove ρ e₁ e₂ (begin
      ⟦ normalise e₁ ⟧⇓ ρ  ≡⟨ P.cong (λ e → ⟦ e ⟧⇓ ρ) eq ⟩
      ⟦ normalise e₂ ⟧⇓ ρ  ∎)

-- This procedure can be combined with from-just.

prove : ∀ n (es : Expr n × Expr n) →
        From-just (uncurry prove′ es)
prove _ = from-just ∘ uncurry prove′


module Data.Num.Next where

open import Data.Num.Core
open import Data.Num.Maximum
open import Data.Num.Bounded

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties.Extra

open import Data.Fin as Fin
    using (Fin; fromℕ≤; inject≤)
    renaming (zero to z; suc to s)

open import Data.Fin.Properties using (toℕ-fromℕ≤; bounded)
open import Data.Product

open import Function
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open ≡-Reasoning
open ≤-Reasoning renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≈⟨_⟩_)
open DecTotalOrder decTotalOrder using (reflexive) renaming (refl to ≤-refl)

--------------------------------------------------------------------------------
-- next-numeral: NullBase
--------------------------------------------------------------------------------

next-numeral-NullBase : ∀ {d o}
    → (xs : Numeral 0 (suc d) o)
    → ¬ (Maximum xs)
    → Numeral 0 (suc d) o
next-numeral-NullBase xs       ¬max with Greatest? (lsd xs)
next-numeral-NullBase xs       ¬max | yes greatest =
    contradiction (Maximum-NullBase-Greatest xs greatest) ¬max
next-numeral-NullBase (x ∙)    ¬max | no ¬greatest = digit+1 x ¬greatest ∙
next-numeral-NullBase (x ∷ xs) ¬max | no ¬greatest = digit+1 x ¬greatest ∷ xs

next-numeral-NullBase-lemma : ∀ {d o}
    → (xs : Numeral 0 (suc d) o)
    → (¬max : ¬ (Maximum xs))
    → ⟦ next-numeral-NullBase xs ¬max ⟧ ≡ suc ⟦ xs ⟧
next-numeral-NullBase-lemma {d} {o} xs    ¬max with Greatest? (lsd xs)
next-numeral-NullBase-lemma {d} {o} xs    ¬max | yes greatest =
    contradiction (Maximum-NullBase-Greatest xs greatest) ¬max
next-numeral-NullBase-lemma {d} {o} (x ∙) ¬max | no ¬greatest =
    begin
        Digit-toℕ (digit+1 x ¬greatest) o
    ≡⟨ digit+1-toℕ x ¬greatest ⟩
        suc (Fin.toℕ x + o)
    ∎
next-numeral-NullBase-lemma {d} {o} (x ∷ xs) ¬max | no ¬greatest =
    begin
        ⟦ digit+1 x ¬greatest ∷ xs ⟧
    ≡⟨ refl ⟩
        Digit-toℕ (digit+1 x ¬greatest) o + ⟦ xs ⟧ * zero
    ≡⟨ cong (λ w → w + ⟦ xs ⟧ * zero) (digit+1-toℕ x ¬greatest) ⟩
        suc (Fin.toℕ x + o + ⟦ xs ⟧ * zero)
    ≡⟨ refl ⟩
        suc ⟦ x ∷ xs ⟧
    ∎

next-numeral-is-greater-NullBase : ∀ {d o}
    → (xs : Numeral 0 (suc d) o)
    → (¬max : ¬ (Maximum xs))
    → ⟦ next-numeral-NullBase xs ¬max ⟧ > ⟦ xs ⟧
next-numeral-is-greater-NullBase xs ¬max =
    start
        suc ⟦ xs ⟧
    ≈⟨ sym (next-numeral-NullBase-lemma xs ¬max) ⟩
        ⟦ next-numeral-NullBase xs ¬max ⟧
    □

next-numeral-is-immediate-NullBase : ∀ {d o}
    → (xs : Numeral 0 (suc d) o)
    → (ys : Numeral 0 (suc d) o)
    → (¬max : ¬ (Maximum xs))
    → ⟦ ys ⟧ > ⟦ xs ⟧
    → ⟦ ys ⟧ ≥ ⟦ next-numeral-NullBase xs ¬max ⟧
next-numeral-is-immediate-NullBase xs ys ¬max prop =
    start
        ⟦ next-numeral-NullBase xs ¬max ⟧
    ≈⟨ next-numeral-NullBase-lemma xs ¬max ⟩
        suc ⟦ xs ⟧
    ≤⟨ prop ⟩
        ⟦ ys ⟧
    □

--------------------------------------------------------------------------------
-- next-numeral: Proper
--------------------------------------------------------------------------------

mutual
    Gapped#0 : ∀ b d o → Set
    Gapped#0 b d o = suc d < carry o * suc b

    Gapped#N : ∀ b d o
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → Set
    Gapped#N b d o xs proper = suc d < (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
        where
            next-xs : Numeral (suc b) (suc d) o
            next-xs = next-numeral-Proper xs proper

    Gapped#0? :  ∀ b d o → Dec (Gapped#0 b d o)
    Gapped#0? b d o = suc (suc d) ≤? carry o * suc b

    Gapped#N? :  ∀ b d o
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → Dec (Gapped#N b d o xs proper)
    Gapped#N? b d o xs proper = suc (suc d) ≤? (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
        where
            next-xs : Numeral (suc b) (suc d) o
            next-xs = next-numeral-Proper xs proper

    -- Gap#N
    Gapped : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → Set
    Gapped {b} {d} {o} (x ∙)    proper = Gapped#0 b d o
    Gapped {b} {d} {o} (x ∷ xs) proper = Gapped#N b d o xs proper

    Gapped? : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → Dec (Gapped {b} {d} {o} xs proper)
    Gapped? {b} {d} {o} (x ∙)    proper = Gapped#0? b d o
    Gapped? {b} {d} {o} (x ∷ xs) proper = Gapped#N? b d o xs proper

    data NextView : (b d o : ℕ) (xs : Numeral b d o) (proper : 2 ≤ d + o) → Set where
        Interval : ∀ b d o
            → {xs : Numeral (suc b) (suc d) o}
            → {proper : 2 ≤ suc (d + o)}
            → (¬greatest : ¬ (Greatest (lsd xs)))
            → NextView (suc b) (suc d) o xs proper
        GappedEndpoint : ∀ b d o
            → {xs : Numeral (suc b) (suc d) o}
            → {proper : 2 ≤ suc (d + o)}
            → (greatest : Greatest (lsd xs))
            → (gapped : Gapped xs proper)
            → NextView (suc b) (suc d) o xs proper
        UngappedEndpoint : ∀ b d o
            → {xs : Numeral (suc b) (suc d) o}
            → {proper : 2 ≤ suc (d + o)}
            → (greatest : Greatest (lsd xs))
            → (¬gapped : ¬ (Gapped xs proper))
            → NextView (suc b) (suc d) o xs proper

    nextView : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → NextView (suc b) (suc d) o xs proper
    nextView {b} {d} {o} xs proper with Greatest? (lsd xs)
    nextView {b} {d} {o} xs proper | yes greatest with Gapped? xs proper
    nextView {b} {d} {o} xs proper | yes greatest | yes gapped = GappedEndpoint  b d o greatest gapped
    nextView {b} {d} {o} xs proper | yes greatest | no ¬gapped = UngappedEndpoint b d o greatest ¬gapped
    nextView {b} {d} {o} xs proper | no ¬greatest = Interval b d o ¬greatest

    next-numeral-Proper-Interval : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (¬greatest : ¬ (Greatest (lsd xs)))
        → (proper : 2 ≤ suc (d + o))
        → Numeral (suc b) (suc d) o
    next-numeral-Proper-Interval (x ∙)    ¬greatest proper = digit+1 x ¬greatest ∙
    next-numeral-Proper-Interval (x ∷ xs) ¬greatest proper = digit+1 x ¬greatest ∷ xs

    next-numeral-Proper-GappedEndpoint : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → (gapped : Gapped xs proper)
        → Numeral (suc b) (suc d) o
    next-numeral-Proper-GappedEndpoint {b} {d} {o} (x ∙)    proper gapped = z ∷ carry-digit d o proper ∙
    next-numeral-Proper-GappedEndpoint {b} {d} {o} (x ∷ xs) proper gapped = z ∷ next-numeral-Proper xs proper

    next-numeral-Proper-UngappedEndpoint : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (greatest : Greatest (lsd xs))
        → (proper : 2 ≤ suc (d + o))
        → (¬gapped : ¬ (Gapped xs proper))
        → Numeral (suc b) (suc d) o
    next-numeral-Proper-UngappedEndpoint {b} {d} {o} (x ∙) greatest proper gapped
        = digit+1-n x greatest (carry o * suc b) lower-bound ∷ carry-digit d o proper ∙
        where
            lower-bound : carry o * suc b > 0
            lower-bound =
                start
                    1
                ≤⟨ m≤m*1+n 1 b ⟩
                    1 * suc b
                ≤⟨ *n-mono (suc b) (m≤m⊔n 1 o) ⟩
                    carry o * suc b
                □

    next-numeral-Proper-UngappedEndpoint {b} {d} {o} (x ∷ xs) greatest proper gapped
        = digit+1-n x greatest gap lower-bound ∷ next-xs
        where
            next-xs : Numeral (suc b) (suc d) o
            next-xs = next-numeral-Proper xs proper

            gap : ℕ
            gap = (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b

            lower-bound : gap > 0
            lower-bound =
                start
                    1
                ≤⟨ m≤m*1+n 1 b ⟩
                    1 * suc b
                ≤⟨ *n-mono (suc b) (m≥n+o⇒m∸o≥n ⟦ next-xs ⟧ 1 ⟦ xs ⟧ (next-numeral-is-greater-Proper xs proper)) ⟩
                    (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
                □

    next-numeral-Proper : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → Numeral (suc b) (suc d) o
    next-numeral-Proper xs proper with nextView xs proper
    next-numeral-Proper xs proper | Interval b d o ¬greatest
        = next-numeral-Proper-Interval xs ¬greatest proper
    next-numeral-Proper xs proper | GappedEndpoint b d o greatest gapped
        = next-numeral-Proper-GappedEndpoint xs proper gapped
    next-numeral-Proper xs proper | UngappedEndpoint b d o greatest ¬gapped
        = next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped

    next-numeral-Proper-Interval-lemma : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (¬greatest : ¬ (Greatest (lsd xs)))
        → (proper : 2 ≤ suc (d + o))
        → ⟦ next-numeral-Proper-Interval xs ¬greatest proper ⟧ ≡ suc ⟦ xs ⟧
    next-numeral-Proper-Interval-lemma {b} {d} {o} (x ∙) ¬greatest proper =
        -- ⟦ digit+1 x ¬greatest ∙ ⟧ ≡ suc ⟦ x ∙ ⟧
        begin
            Digit-toℕ (digit+1 x ¬greatest) o
        ≡⟨ digit+1-toℕ x ¬greatest ⟩
            suc (Digit-toℕ x o)
        ∎
    next-numeral-Proper-Interval-lemma {b} {d} {o} (x ∷ xs) ¬greatest proper =
    -- ⟦ digit+1 x ¬greatest ∷ xs ⟧ ≡ suc ⟦ x ∷ xs ⟧
        begin
            Digit-toℕ (digit+1 x ¬greatest) o + ⟦ xs ⟧ * suc b
        ≡⟨ cong (λ w → w + ⟦ xs ⟧ * suc b) (digit+1-toℕ x ¬greatest) ⟩
            suc (Digit-toℕ x o) + ⟦ xs ⟧ * suc b
        ∎

    next-numeral-Proper-GappedEndpoint-lemma : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (greatest : Greatest (lsd xs))
        → (proper : 2 ≤ suc (d + o))
        → (gapped : Gapped xs proper)
        → ⟦ next-numeral-Proper-GappedEndpoint xs proper gapped ⟧ > suc ⟦ xs ⟧
    next-numeral-Proper-GappedEndpoint-lemma {b} {d} {o} (x ∙) greatest proper gapped =
        -- ⟦ z ∷ carry-digit d o proper ∙ ⟧ > suc ⟦ x ∙ ⟧
        start
            suc (suc (Fin.toℕ x + o))
        ≈⟨ cong (λ w → suc w + o) greatest ⟩
            suc (suc d) + o
        ≈⟨ +-comm (suc (suc d)) o ⟩
            o + suc (suc d)
        ≤⟨ n+-mono o gapped ⟩
            o + carry o * suc b
        ≈⟨ cong (λ w → o + w * suc b) (sym (carry-digit-toℕ d o proper)) ⟩
            o + (Digit-toℕ (carry-digit d o proper) o) * suc b
        □
    next-numeral-Proper-GappedEndpoint-lemma {b} {d} {o} (x ∷ xs) greatest proper gapped
        = proof
        where
            next-xs : Numeral (suc b) (suc d) o
            next-xs = next-numeral-Proper xs proper

            next-xs>xs : ⟦ next-xs ⟧ > ⟦ xs ⟧
            next-xs>xs = next-numeral-is-greater-Proper xs proper

            next : Numeral (suc b) (suc d) o
            next = z ∷ next-xs

            -- ⟦ z ∷ next-numeral-Proper xs (Maximum-Proper xs proper) proper ⟧ > suc ⟦ x ∷ xs ⟧
            proof : ⟦ next ⟧ > suc ⟦ x ∷ xs ⟧
            proof = start
                    suc (suc (Digit-toℕ x o)) + ⟦ xs ⟧ * suc b
                ≈⟨ cong (λ w → suc (suc w) + ⟦ xs ⟧ * suc b) (greatest-digit-toℕ x greatest) ⟩
                    suc (suc d) + o + ⟦ xs ⟧ * suc b
                ≈⟨ +-assoc (suc (suc d)) o (⟦ xs ⟧ * suc b) ⟩
                    suc (suc d) + (o + ⟦ xs ⟧ * suc b)
                ≈⟨ a+[b+c]≡b+[a+c] (suc (suc d)) o (⟦ xs ⟧ * suc b) ⟩
                    o + (suc (suc d) + ⟦ xs ⟧ * suc b)
                ≤⟨ n+-mono o (+n-mono (⟦ xs ⟧ * suc b) gapped) ⟩
                    o + ((⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b + ⟦ xs ⟧ * suc b)
                ≈⟨ cong (λ w → o + w) (sym (distribʳ-*-+ (suc b) (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) ⟦ xs ⟧)) ⟩
                    o + (⟦ next-xs ⟧ ∸ ⟦ xs ⟧ + ⟦ xs ⟧) * suc b
                ≈⟨ cong (λ w → o + w * suc b) (m∸n+n≡m (<⇒≤ next-xs>xs)) ⟩
                    o + ⟦ next-xs ⟧ * suc b
                ≈⟨ refl ⟩
                    ⟦ z ∷ next-xs ⟧
                □

    next-numeral-Proper-UngappedEndpoint-lemma : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (greatest : Greatest (lsd xs))
        → (proper : 2 ≤ suc (d + o))
        → (¬gapped : ¬ (Gapped xs proper))
        → ⟦ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped ⟧ ≡ suc ⟦ xs ⟧
    next-numeral-Proper-UngappedEndpoint-lemma {b} {d} {o} (x ∙) greatest proper ¬gapped = proof
        -- ⟦ digit+1-n x greatest (carry o * suc b) lower-bound ∷ carry-digit d o proper ∙ ⟧ ≡ suc ⟦ x ∙ ⟧
        where
            lower-bound : carry o * suc b > 0
            lower-bound =
                start
                    1
                ≤⟨ m≤m*1+n 1 b ⟩
                    1 * suc b
                ≤⟨ *n-mono (suc b) (m≤m⊔n 1 o) ⟩
                    carry o * suc b
                □

            upper-bound : carry o * suc b ≤ suc d
            upper-bound = ≤-pred $ ≰⇒> ¬gapped

            upper-bound' : carry o * suc b ≤ suc (Fin.toℕ x + o)
            upper-bound' = start
                    carry o * suc b
                ≤⟨ upper-bound ⟩
                    suc d
                ≈⟨ sym greatest ⟩
                    suc (Fin.toℕ x)
                ≤⟨ m≤m+n (suc (Fin.toℕ x)) o ⟩
                    suc (Fin.toℕ x + o)
                □

            next : Numeral (suc b) (suc d) o
            next = digit+1-n x greatest (carry o * suc b) lower-bound ∷ carry-digit d o proper ∙

            proof : ⟦ next ⟧ ≡ suc (Digit-toℕ x o)
            proof =
                begin
                    Digit-toℕ (digit+1-n x greatest (carry o * suc b) lower-bound) o + Digit-toℕ (carry-digit d o proper) o * suc b
                ≡⟨ cong (λ w → Digit-toℕ (digit+1-n x greatest (carry o * suc b) lower-bound) o + w * suc b) (carry-digit-toℕ d o proper) ⟩
                    Digit-toℕ (digit+1-n x greatest (carry o * suc b) lower-bound) o + carry o * suc b
                ≡⟨ cong (λ w → w + carry o * suc b) (digit+1-n-toℕ x greatest (carry o * suc b) lower-bound upper-bound) ⟩
                    suc (Fin.toℕ x + o) ∸ carry o * suc b + carry o * suc b
                ≡⟨ m∸n+n≡m upper-bound' ⟩
                    suc (Digit-toℕ x o)
                ∎
    next-numeral-Proper-UngappedEndpoint-lemma {b} {d} {o} (x ∷ xs) greatest proper ¬gapped = proof
        -- ⟦ digit+1-n x greatest gap gap>0 ∷ next ∙ ⟧ ≡ suc ⟦ x ∷ xs ⟧
        where
            ¬max-xs : ¬ (Maximum xs)
            ¬max-xs = Maximum-Proper xs proper

            next-xs : Numeral (suc b) (suc d) o
            next-xs = next-numeral-Proper xs proper

            lower-bound : (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b > 0
            lower-bound =
                start
                    1
                ≤⟨ m≤m*1+n 1 b ⟩
                    1 * suc b
                ≤⟨ *n-mono (suc b) (m≥n+o⇒m∸o≥n ⟦ next-xs ⟧ 1 ⟦ xs ⟧ (next-numeral-is-greater-Proper xs proper)) ⟩
                    (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
                □

            upper-bound : (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b ≤ suc d
            upper-bound = ≤-pred $ ≰⇒> ¬gapped

            next : Numeral (suc b) (suc d) o
            next = digit+1-n x greatest ((⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b) lower-bound ∷ next-xs

            ⟦next-xs⟧>⟦xs⟧ : ⟦ next-xs ⟧ > ⟦ xs ⟧
            ⟦next-xs⟧>⟦xs⟧ = next-numeral-is-greater-Proper xs proper

            upper-bound' : ⟦ next-xs ⟧ * suc b ∸ ⟦ xs ⟧ * suc b ≤ suc (Digit-toℕ x o)
            upper-bound' =
                start
                    ⟦ next-xs ⟧ * suc b ∸ ⟦ xs ⟧ * suc b
                ≈⟨ sym (*-distrib-∸ʳ (suc b) ⟦ next-xs ⟧ ⟦ xs ⟧) ⟩
                    (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
                ≤⟨ upper-bound ⟩
                    suc d
                ≤⟨ m≤m+n (suc d) o ⟩
                    suc d + o
                ≈⟨ cong (λ w → w + o) (sym greatest) ⟩
                    suc (Digit-toℕ x o)
                □

            proof : ⟦ next ⟧ ≡ suc ⟦ x ∷ xs ⟧
            proof =
                begin
                    ⟦ next ⟧
                ≡⟨ cong (λ w → w + ⟦ next-xs ⟧ * suc b) (digit+1-n-toℕ x greatest ((⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b) lower-bound upper-bound) ⟩
                    suc (Digit-toℕ x o) ∸ (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b + ⟦ next-xs ⟧ * suc b
                ≡⟨ cong (λ w → suc (Digit-toℕ x o) ∸ w + ⟦ next-xs ⟧ * suc b) (*-distrib-∸ʳ (suc b) ⟦ next-xs ⟧ ⟦ xs ⟧) ⟩
                    suc (Digit-toℕ x o) ∸ (⟦ next-xs ⟧ * suc b ∸ ⟦ xs ⟧ * suc b) + ⟦ next-xs ⟧ * suc b
                ≡⟨ m∸[o∸n]+o≡m+n (suc (Digit-toℕ x o)) (⟦ xs ⟧ * suc b) (⟦ next-xs ⟧ * suc b) (*n-mono (suc b) (<⇒≤ ⟦next-xs⟧>⟦xs⟧)) upper-bound' ⟩
                    suc ⟦ x ∷ xs ⟧
                ∎

    next-numeral-is-greater-Proper : ∀ {b d o}
        → (xs : Numeral (suc b) (suc d) o)
        → (proper : 2 ≤ suc (d + o))
        → ⟦ next-numeral-Proper xs proper ⟧ > ⟦ xs ⟧
    next-numeral-is-greater-Proper xs proper with nextView xs proper
    next-numeral-is-greater-Proper xs proper | Interval b d o ¬greatest =
        start
            suc ⟦ xs ⟧
        ≈⟨ sym (next-numeral-Proper-Interval-lemma xs ¬greatest proper) ⟩
            ⟦ next-numeral-Proper-Interval xs ¬greatest proper ⟧
        □
    next-numeral-is-greater-Proper xs proper | GappedEndpoint b d o greatest gapped =
        start
            suc ⟦ xs ⟧
        ≤⟨ n≤1+n (suc ⟦ xs ⟧) ⟩
            suc (suc ⟦ xs ⟧)
        ≤⟨ next-numeral-Proper-GappedEndpoint-lemma xs greatest proper gapped ⟩
            ⟦ next-numeral-Proper-GappedEndpoint xs proper gapped ⟧
        □
    next-numeral-is-greater-Proper xs proper | UngappedEndpoint b d o greatest ¬gapped =
        start
            suc ⟦ xs ⟧
        ≈⟨ sym (next-numeral-Proper-UngappedEndpoint-lemma xs greatest proper ¬gapped) ⟩
            ⟦ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped ⟧
        □

-- gap : ∀ {b d o}
--     → (xs : Numeral (suc b) (suc d) o)
--     → (proper : 2 ≤ suc (d + o))
--     → ℕ
-- gap {b} {d} {o} (x ∙)    proper = carry o                * suc b
-- gap {b} {d} {o} (x ∷ xs) proper = (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
--     where
--         next-xs : Numeral (suc b) (suc d) o
--         next-xs = next-numeral-Proper xs proper
--
-- gap>0 : ∀ {b d o}
--     → (xs : Numeral (suc b) (suc d) o)
--     → (proper : 2 ≤ suc (d + o))
--     → gap xs proper > 0
-- gap>0 {b} {d} {o} (x ∙)    proper =
--     start
--         1
--     ≤⟨ m≤m*1+n 1 b ⟩
--         1 * suc b
--     ≤⟨ *n-mono (suc b) (m≤m⊔n 1 o) ⟩
--         carry o * suc b
--     □
-- gap>0 {b} {d} {o} (x ∷ xs) proper =
--     start
--         1
--     ≤⟨ m≤m*1+n 1 b ⟩
--         1 * suc b
--     ≤⟨ *n-mono (suc b) (m≥n+o⇒m∸o≥n ⟦ next-xs ⟧ 1 ⟦ xs ⟧ (next-numeral-is-greater-Proper xs proper)) ⟩
--         (⟦ next-xs ⟧ ∸ ⟦ xs ⟧) * suc b
--     □
--     where
--         next-xs : Numeral (suc b) (suc d) o
--         next-xs = next-numeral-Proper xs proper
--------------------------------------------------------------------------------
-- Properties of next-numeral on Proper Numbers
--------------------------------------------------------------------------------

next-numeral-Proper-refine-target : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → NextView (suc b) (suc d) o xs proper
    → Set
next-numeral-Proper-refine-target xs proper (Interval b d o ¬greatest) = next-numeral-Proper xs proper ≡ next-numeral-Proper-Interval xs ¬greatest proper
next-numeral-Proper-refine-target xs proper (GappedEndpoint b d o greatest gapped) = next-numeral-Proper xs proper ≡ next-numeral-Proper-GappedEndpoint xs proper gapped
next-numeral-Proper-refine-target xs proper (UngappedEndpoint b d o greatest ¬gapped) = next-numeral-Proper xs proper ≡ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped

next-numeral-Proper-refine : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → (view : NextView (suc b) (suc d) o xs proper)
    → next-numeral-Proper-refine-target xs proper view
next-numeral-Proper-refine xs proper (Interval b d o ¬greatest) with nextView xs proper
next-numeral-Proper-refine xs proper (Interval b d o ¬greatest) | Interval _ _ _ _ = refl
next-numeral-Proper-refine xs proper (Interval b d o ¬greatest) | GappedEndpoint _ _ _ greatest _ = contradiction greatest ¬greatest
next-numeral-Proper-refine xs proper (Interval b d o ¬greatest) | UngappedEndpoint _ _ _ greatest _ = contradiction greatest ¬greatest
next-numeral-Proper-refine xs proper (GappedEndpoint b d o greatest gapped) with nextView xs proper
next-numeral-Proper-refine xs proper (GappedEndpoint b d o greatest gapped) | Interval _ _ _ ¬greatest = contradiction greatest ¬greatest
next-numeral-Proper-refine xs proper (GappedEndpoint b d o greatest gapped) | GappedEndpoint _ _ _ _ _ = refl
next-numeral-Proper-refine xs proper (GappedEndpoint b d o greatest gapped) | UngappedEndpoint _ _ _ _ ¬gapped = contradiction gapped ¬gapped
next-numeral-Proper-refine xs proper (UngappedEndpoint b d o greatest ¬gapped) with nextView xs proper
next-numeral-Proper-refine xs proper (UngappedEndpoint b d o greatest ¬gapped) | Interval _ _ _ ¬greatest = contradiction greatest ¬greatest
next-numeral-Proper-refine xs proper (UngappedEndpoint b d o greatest ¬gapped) | GappedEndpoint _ _ _ _ gapped = contradiction gapped ¬gapped
next-numeral-Proper-refine xs proper (UngappedEndpoint b d o greatest ¬gapped) | UngappedEndpoint _ _ _ _ _ = refl

--------------------------------------------------------------------------------
-- next-numeral-is-immediate-Proper
--------------------------------------------------------------------------------

next-numeral-is-immediate-Proper : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (ys : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → ⟦ ys ⟧ > ⟦ xs ⟧
    → ⟦ ys ⟧ ≥ ⟦ next-numeral-Proper xs proper ⟧
next-numeral-is-immediate-Proper xs ys proper prop with nextView xs proper
next-numeral-is-immediate-Proper xs ys proper prop | Interval b d o ¬greatest =
    start
        ⟦ next-numeral-Proper-Interval xs ¬greatest proper ⟧
    ≈⟨ next-numeral-Proper-Interval-lemma xs ¬greatest proper ⟩
        suc ⟦ xs ⟧
    ≤⟨ prop ⟩
        ⟦ ys ⟧
    □
next-numeral-is-immediate-Proper xs (y ∙) proper prop | GappedEndpoint b d o greatest gapped
    = contradiction prop $ >⇒≰ $
        start
            suc (Digit-toℕ y o)
        ≤⟨ s≤s (greatest-of-all o (lsd xs) y greatest) ⟩
            suc (Digit-toℕ (lsd xs) o)
        ≤⟨ s≤s (lsd-toℕ xs) ⟩
            suc ⟦ xs ⟧
        □
next-numeral-is-immediate-Proper (x ∙) (y ∷ ys) proper prop | GappedEndpoint b d o greatest gapped =
    start
        o + (Digit-toℕ (carry-digit d o proper) o) * suc b
    ≈⟨ cong (λ w → o + w * suc b) (carry-digit-toℕ d o proper) ⟩
        o + carry o * suc b
    ≤⟨ n+-mono o (*n-mono (suc b) ys-lower-bound) ⟩
        o + ⟦ ys ⟧ * suc b
    ≤⟨ +n-mono (⟦ ys ⟧ * suc b) (n≤m+n (Fin.toℕ y) o) ⟩
        Digit-toℕ y o + ⟦ ys ⟧ * suc b
    □
    where
        ≥carry : ∀ {b d o}
            → (xs : Numeral (suc b) (suc d) o)
            → (proper : 2 ≤ suc (d + o))
            → ⟦ xs ⟧ > 0
            → ⟦ xs ⟧ ≥ carry o
        ≥carry {_} {_} {zero}  xs proper prop = prop
        ≥carry {_} {_} {suc o} (x ∙) proper prop = n≤m+n (Fin.toℕ x) (suc o)
        ≥carry {b} {_} {suc o} (x ∷ xs) proper prop =
            start
                suc o
            ≤⟨ n≤m+n (Fin.toℕ x) (suc o) ⟩
                Fin.toℕ x + suc o
            ≤⟨ m≤m+n (Fin.toℕ x + suc o) (⟦ xs ⟧ * suc b) ⟩
                Fin.toℕ x + suc o + ⟦ xs ⟧ * suc b
            □

        ys-lower-bound : ⟦ ys ⟧ ≥ carry o
        ys-lower-bound = ≥carry ys proper (tail-mono-strict-Null x y ys greatest prop)

next-numeral-is-immediate-Proper (x ∷ xs) (y ∷ ys) proper prop | GappedEndpoint b d o greatest gapped =
    start
        o + ⟦ next-xs ⟧ * suc b
    ≤⟨ n+-mono o (*n-mono (suc b) ⟦next-xs⟧≤⟦ys⟧) ⟩
        o + ⟦ ys ⟧ * suc b
    ≤⟨ +n-mono (⟦ ys ⟧ * suc b) (n≤m+n (Fin.toℕ y) o) ⟩
        Digit-toℕ y o + ⟦ ys ⟧ * suc b
    □
    where
        next-xs : Numeral (suc b) (suc d) o
        next-xs = next-numeral-Proper xs proper

        ⟦xs⟧<⟦ys⟧ : ⟦ xs ⟧ < ⟦ ys ⟧
        ⟦xs⟧<⟦ys⟧ = tail-mono-strict x xs y ys greatest prop

        ⟦next-xs⟧≤⟦ys⟧ : ⟦ next-xs ⟧ ≤ ⟦ ys ⟧
        ⟦next-xs⟧≤⟦ys⟧ = next-numeral-is-immediate-Proper xs ys proper ⟦xs⟧<⟦ys⟧

next-numeral-is-immediate-Proper xs ys proper prop | UngappedEndpoint b d o greatest ¬gapped =
    start
        ⟦ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped ⟧
    ≈⟨ next-numeral-Proper-UngappedEndpoint-lemma xs greatest proper ¬gapped ⟩
        suc ⟦ xs ⟧
    ≤⟨ prop ⟩
        ⟦ ys ⟧
    □

--------------------------------------------------------------------------------
-- next-numeral
--------------------------------------------------------------------------------

next-numeral : ∀ {b d o}
    → (xs : Numeral b d o)
    → ¬ (Maximum xs)
    → Numeral b d o
next-numeral {b} {d} {o} xs ¬max with numView b d o
next-numeral xs ¬max | NullBase d o = next-numeral-NullBase xs ¬max
next-numeral xs ¬max | NoDigits b o = NoDigits-explode xs
next-numeral xs ¬max | AllZeros b   = contradiction (Maximum-AllZeros xs) ¬max
next-numeral xs ¬max | Proper b d o proper = next-numeral-Proper xs proper

--------------------------------------------------------------------------------
-- next-numeral-is-greater
--------------------------------------------------------------------------------

next-numeral-is-greater : ∀ {b d o}
    → (xs : Numeral b d o)
    → (¬max : ¬ (Maximum xs))
    → ⟦ next-numeral xs ¬max ⟧ > ⟦ xs ⟧
next-numeral-is-greater {b} {d} {o} xs ¬max with numView b d o
next-numeral-is-greater xs ¬max | NullBase d o = next-numeral-is-greater-NullBase xs ¬max
next-numeral-is-greater xs ¬max | NoDigits b o = NoDigits-explode xs
next-numeral-is-greater xs ¬max | AllZeros b   = contradiction (Maximum-AllZeros xs) ¬max
next-numeral-is-greater xs ¬max | Proper b d o proper = next-numeral-is-greater-Proper xs proper

--------------------------------------------------------------------------------
-- next-numeral-is-immediate
--------------------------------------------------------------------------------

next-numeral-is-immediate : ∀ {b d o}
    → (xs : Numeral b d o)
    → (ys : Numeral b d o)
    → (¬max : ¬ (Maximum xs))
    → ⟦ ys ⟧ > ⟦ xs ⟧
    → ⟦ ys ⟧ ≥ ⟦ next-numeral xs ¬max ⟧
next-numeral-is-immediate {b} {d} {o} xs ys ¬max prop with numView b d o
next-numeral-is-immediate xs ys ¬max prop | NullBase d o = next-numeral-is-immediate-NullBase xs ys ¬max prop
next-numeral-is-immediate xs ys ¬max prop | NoDigits b o = NoDigits-explode xs
next-numeral-is-immediate xs ys ¬max prop | AllZeros b = contradiction (Maximum-AllZeros xs) ¬max
next-numeral-is-immediate xs ys ¬max prop | Proper b d o proper = next-numeral-is-immediate-Proper xs ys proper prop

--------------------------------------------------------------------------------
-- properties of the gaps
--------------------------------------------------------------------------------

Gapped#N⇒Gapped#0 : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → Gapped#N b d o xs proper
    → Gapped#0 b d o
Gapped#N⇒Gapped#0 xs proper gapped#N with nextView xs proper
Gapped#N⇒Gapped#0 xs proper gapped#N | Interval b d o ¬greatest =
    start
        suc (suc d)
    ≤⟨ gapped#N ⟩
        (⟦ next-numeral-Proper-Interval xs ¬greatest proper ⟧ ∸ ⟦ xs ⟧) * suc b
    ≤⟨ *n-mono (suc b) $
        start
            ⟦ next-numeral-Proper-Interval xs ¬greatest proper ⟧ ∸ ⟦ xs ⟧
        ≈⟨ cong (λ w → w ∸ ⟦ xs ⟧) (next-numeral-Proper-Interval-lemma xs ¬greatest proper) ⟩
            suc ⟦ xs ⟧ ∸ ⟦ xs ⟧
        ≈⟨ m+n∸n≡m (suc zero) ⟦ xs ⟧ ⟩
            suc zero
        ≤⟨ m≤m⊔n 1 o ⟩
            suc zero ⊔ o
        □
     ⟩
        (suc zero ⊔ o) * suc b
    □
Gapped#N⇒Gapped#0 (x ∙)    proper gapped#N | GappedEndpoint b d o greatest gapped#0 = gapped#0
Gapped#N⇒Gapped#0 (x ∷ xs) proper _        | GappedEndpoint b d o greatest gapped#N = Gapped#N⇒Gapped#0 xs proper gapped#N
Gapped#N⇒Gapped#0 xs proper gapped#N | UngappedEndpoint b d o greatest ¬gapped =
        start
            suc (suc d)
        ≤⟨ gapped#N ⟩
            (⟦ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped ⟧ ∸ ⟦ xs ⟧) * suc b
        ≤⟨ *n-mono (suc b) $
            start
                ⟦ next-numeral-Proper-UngappedEndpoint xs greatest proper ¬gapped ⟧ ∸ ⟦ xs ⟧
            ≈⟨ cong (λ w → w ∸ ⟦ xs ⟧) (next-numeral-Proper-UngappedEndpoint-lemma xs greatest proper ¬gapped) ⟩
                suc ⟦ xs ⟧ ∸ ⟦ xs ⟧
            ≈⟨ m+n∸n≡m (suc zero) ⟦ xs ⟧ ⟩
                suc zero
            ≤⟨ m≤m⊔n 1 o ⟩
                suc zero ⊔ o
            □
         ⟩
            (suc zero ⊔ o) * suc b
        □

-- ¬Gapped#0⇒¬Gapped#N : ∀ {b d o}
--     → (xs : Numeral (suc b) (suc d) o)
--     → (proper : 2 ≤ suc (d + o))
--     → ¬ (Gapped#0 b d o)
--     → ¬ (Gapped#N b d o xs proper)
-- ¬Gapped#0⇒¬Gapped#N xs proper ¬Gapped#0 = contraposition (Gapped#N⇒Gapped#0 xs proper) ¬Gapped#0

¬Gapped#0⇒¬Gapped : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → ¬ (Gapped#0 b d o)
    → ¬ (Gapped xs proper)
¬Gapped#0⇒¬Gapped (x ∙)    proper ¬Gapped#0 = ¬Gapped#0
¬Gapped#0⇒¬Gapped (x ∷ xs) proper ¬Gapped#0 = contraposition
    (Gapped#N⇒Gapped#0 xs proper)
    ¬Gapped#0


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Classical.SequentCalculus (𝔏 : Signature) where
open Signature(𝔏)

open import Data.List
open import Data.List.Functions using () renaming (singleton to · ; _++_ to _∪_)
open import Data.List.Relation.Permutation
open import Formalization.PredicateLogic.Syntax(𝔏)
open import Formalization.PredicateLogic.Syntax.Substitution(𝔏)
open import Functional as Fn
import      Lvl
open import Numeral.Finite
open import Numeral.Natural
open import Type

private variable ℓ : Lvl.Level
private variable n vars : ℕ

_∪·_ : ∀{T : Type{ℓ}} → List(T) → T → List(T)
_∪·_ = Fn.swap(_⊰_)
infixl 1000 _∪·_

module _ where
  private variable Γ Γ₁ Γ₂ Γ₃ Δ Δ₁ Δ₂ Δ₃ : List(Formula(vars))
  private variable φ φ₁ φ₂ ψ A B C : Formula(vars)
  private variable p : Prop(n)

  data _⇒_ : List(Formula(vars)) → List(Formula(vars)) → Type{Lvl.𝐒(ℓₚ Lvl.⊔ ℓₒ)} where
    axiom : ((· φ) ⇒ (· φ))

    weakenₗ : (Γ ⇒ Δ) → ((Γ ∪· A) ⇒ Δ)
    permuteₗ : .(Γ₁ permutes Γ₂) → (Γ₁ ⇒ Δ) → (Γ₂ ⇒ Δ)
    contractₗ : ((Γ ∪· A ∪· A) ⇒ Δ) → ((Γ ∪· A) ⇒ Δ)
    ⊥ₗ : (Γ ∪· ⊥) ⇒ ∅
    ∧ₗₗ : ((Γ ∪· A) ⇒ Δ) → ((Γ ∪· (A ∧ B)) ⇒ Δ)
    ∧ₗᵣ : ((Γ ∪· B) ⇒ Δ) → ((Γ ∪· (A ∧ B)) ⇒ Δ)
    ∨ₗ : ((Γ ∪· A) ⇒ Δ) → ((Γ ∪· B) ⇒ Δ) → ((Γ ∪· (A ∨ B)) ⇒ Δ)
    ⟶ₗ : (Γ ⇒ (Δ ∪· A)) → ((Γ ∪· B) ⇒ Δ) → ((Γ ∪· (A ⟶ B)) ⇒ Δ)
    Ɐₗ : ∀{t} → ((Γ ∪· (substitute0 t A)) ⇒ Δ) → ((Γ ∪· (Ɐ A)) ⇒ Δ)
    ∃ₗ : ∀{v}{n} → ((Γ ∪· (substituteN n (var v) A)) ⇒ Δ) → ((Γ ∪· (∃ A)) ⇒ Δ)

    weakenᵣ : (Γ ⇒ Δ) → (Γ ⇒ (Δ ∪· A))
    permuteᵣ : .(Δ₁ permutes Δ₂) → (Γ ⇒ Δ₁) → (Γ ⇒ Δ₂)
    contractᵣ : (Γ ⇒ (Δ ∪· A ∪· A)) → (Γ ⇒ (Δ ∪· A))
    ⊤ᵣ : ∅ ⇒ (Δ ∪· ⊤)
    ∧ᵣ : (Γ ⇒ (Δ ∪· A)) → (Γ ⇒ (Δ ∪· B)) → (Γ ⇒ (Δ ∪· (A ∧ B)))
    ∨ᵣₗ : (Γ ⇒ (Δ ∪· A)) → (Γ ⇒ (Δ ∪· (A ∨ B)))
    ∨ᵣᵣ : (Γ ⇒ (Δ ∪· B)) → (Γ ⇒ (Δ ∪· (A ∨ B)))
    ⟶ᵣ : ((Γ ∪· A) ⇒ (Δ ∪· B)) → (Γ ⇒ (Δ ∪· (A ⟶ B)))
    Ɐᵣ : ∀{v}{n} → (Γ ⇒ (Δ ∪· (substituteN n (var v) A))) → (Γ ⇒ (Δ ∪· (Ɐ A)))
    ∃ᵣ : ∀{t} → (Γ ⇒ (Δ ∪· (substitute0 t A))) → (Γ ⇒ (Δ ∪· (∃ A)))


module my-integer where

open import bool
open import bool-thms2
open import eq
open import nat
open import nat-thms
open import product
--open import product-thms
open import sum
-- open import unit

data ⊤ : Set where
  triv : ⊤

ℤ-pos-t : ℕ → Set
ℤ-pos-t 0 = ⊤
ℤ-pos-t (suc _) = 𝔹

data ℤ : Set where
  mkℤ : (n : ℕ) → ℤ-pos-t n → ℤ

0ℤ : ℤ
0ℤ = mkℤ 0 triv

1ℤ : ℤ
1ℤ = mkℤ 1 tt

-1ℤ : ℤ
-1ℤ = mkℤ 1 ff

abs-val : ℤ → ℕ
abs-val (mkℤ n _) = n

is-evenℤ : ℤ → 𝔹
is-evenℤ (mkℤ n _) = is-even n

is-oddℤ : ℤ → 𝔹
is-oddℤ (mkℤ n _) = is-odd n

{- subtract the second natural number from the first, returning an integer.
   This is mostly a helper for _+ℤ_ -}
diffℤ : ℕ → ℕ → ℤ
diffℤ n m with ℕ-trichotomy n m
diffℤ n m | inj₁ p with <∸suc{m}{n} p               -- n < m
diffℤ n m | inj₁ p | x , _ = mkℤ (suc x) ff
diffℤ n m | inj₂ (inj₁ p) = mkℤ 0 triv              -- n = m
diffℤ n m | inj₂ (inj₂ p) with <∸suc{n}{m} p
diffℤ n m | inj₂ (inj₂ p) | x , _ = mkℤ (suc x) tt  -- m < n

_+ℤ_ : ℤ → ℤ → ℤ
(mkℤ 0 _) +ℤ x = x
x +ℤ (mkℤ 0 _) = x
(mkℤ (suc n) p1) +ℤ (mkℤ (suc m) p2) with p1 xor p2
(mkℤ (suc n) p1) +ℤ (mkℤ (suc m) p2) | ff = mkℤ (suc n + suc m) p1
(mkℤ (suc n) p1) +ℤ (mkℤ (suc m) p2) | tt = if p1 imp p2 then diffℤ m n else diffℤ n m


{-# OPTIONS --without-K #-}
module NTypes.Negation where

open import FunExt
open import NTypes
open import Types

¬-isProp : ∀ {a} {A : Set a} → isProp (¬ A)
¬-isProp ¬a _ = funext λ a → 0-elim (¬a a)


module Formalization.ClassicalPropositionalLogic.NaturalDeduction.Proofs where

open import Data.Boolean
open import Data.Either
open import Functional
open import Formalization.ClassicalPropositionalLogic.NaturalDeduction
open import Formalization.ClassicalPropositionalLogic.Place
open import Formalization.ClassicalPropositionalLogic.Syntax
import      Lvl
open import Logic
import      Logic.Propositional as Meta
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Sets.PredicateSet using (PredSet ; _∈_ ; _∉_ ; _∪_ ; _∪•_ ; _∖_ ; _⊆_ ; _⊇_ ; ∅ ; [≡]-to-[⊆] ; [≡]-to-[⊇]) renaming (•_ to singleton ; _≡_ to _≡ₛ_)
open import Type

private variable ℓₚ ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T A B : Type{ℓ}
private variable P : Type{ℓₚ}
private variable φ ψ γ : Formula(P)
private variable Γ : Formulas(P){ℓ}
private variable f : A → B
private variable s e : Bool
private variable p : P

module _ where
  [¬]-intro-converse : ((Γ ∪ singleton(φ)) ⊢ ⊥) ← (Γ ⊢ (¬ φ))
  [¬]-intro-converse {Γ = Γ}{φ = φ} Γ¬φ = [⊥]-intro (direct (Right [≡]-intro)) (weaken-union Γ¬φ)

  excluded-middle : Γ ⊢ (φ ∨ (¬ φ))
  excluded-middle =
    ([¬¬]-elim
      ([¬]-intro
        ([⊥]-intro
          ([∨]-introᵣ
            ([¬]-intro
              ([⊥]-intro
                ([∨]-introₗ (direct (Right [≡]-intro)))
                (direct (Left (Right [≡]-intro)))
              )
            )
          )
          (direct (Right [≡]-intro))
        )
      )
    )

  [→]-disjunctive-form : (Γ ⊢ (φ ⟶ ψ)) Meta.↔ (Γ ⊢ ((¬ φ) ∨ ψ))
  [→]-disjunctive-form = Meta.[↔]-intro l r where
    l = [∨]-elim
      ([⟶]-intro ([⊥]-elim ([⊥]-intro
        (direct (Right [≡]-intro))
        (direct (Left (Right [≡]-intro)))
      )))
      ([⟶]-intro (direct (Left (Right [≡]-intro))))
    r = pq ↦
      ([∨]-elim
        ([∨]-introᵣ ([⟶]-elim (direct (Right [≡]-intro)) (weaken Left pq)))
        ([∨]-introₗ (direct (Right [≡]-intro)))
        excluded-middle
      )

  [⟷]-negated : (Γ ⊢ (φ ⟷ ψ)) → (Γ ⊢ ((¬ φ) ⟷ (¬ ψ)))
  [⟷]-negated p = [⟷]-intro
    ([¬]-intro ([⊥]-intro ([⟷]-elimᵣ (direct (Right [≡]-intro)) (weaken (Left ∘ Left) p)) (direct (Left (Right [≡]-intro)))))
    (([¬]-intro ([⊥]-intro ([⟷]-elimₗ (direct (Right [≡]-intro)) (weaken (Left ∘ Left) p)) (direct (Left (Right [≡]-intro))))))

  [⟷]-conjunction-disjunction-negation : (Γ ⊢ (φ ⟷ ψ)) Meta.↔ (Γ ⊢ ((φ ∧ ψ) ∨ ((¬ φ) ∧ (¬ ψ))))
  [⟷]-conjunction-disjunction-negation = Meta.[↔]-intro l r where
    l = [∨]-elim
      ([⟷]-intro
        ([∧]-elimₗ (direct (Left (Right [≡]-intro))))
        ([∧]-elimᵣ (direct (Left (Right [≡]-intro))))
      )
      ([⟷]-intro
        ([⊥]-elim ([⊥]-intro (direct (Right [≡]-intro)) ([∧]-elimᵣ (direct (Left (Right [≡]-intro))))))
        ([⊥]-elim ([⊥]-intro (direct (Right [≡]-intro)) ([∧]-elimₗ (direct (Left (Right [≡]-intro))))))
      )
    r = p ↦ [∨]-elim
      ([∨]-introₗ ([∧]-intro
        (direct (Right [≡]-intro))
        ([⟷]-elimᵣ (direct (Right [≡]-intro)) (weaken Left p))
      ))
      ([∨]-introᵣ ([∧]-intro
        (direct (Right [≡]-intro))
        ([⟷]-elimᵣ (direct (Right [≡]-intro)) (weaken Left ([⟷]-negated p)))
      ))
      excluded-middle

-- TODO: The two proofs contain very similar cases (the structure is identical in all cases). Are there any good ways to generalize? Maybe by using the strict variants?
positive-congruence : Positive(P) f → (Γ ⊢ (φ ⟶ ψ) ⟶ (f(φ) ⟶ f(ψ)))
negative-congruence : Negative(P) f → (Γ ⊢ (φ ⟶ ψ) ⟶ (f(φ) ⟵ f(ψ)))

positive-congruence identity           = [⟶]-intro ([⟶]-intro ([⟶]-elim (direct (Right [≡]-intro)) (direct (Left (Right [≡]-intro)))))
positive-congruence (conjunctionₗ ctx) =
  [⟶]-intro ([⟶]-intro ([∧]-intro
    ([∧]-elimₗ (direct (Right [≡]-intro)))
    ([⟶]-elim ([∧]-elimᵣ (direct (Right [≡]-intro))) ([⟶]-elim (direct (Left (Right [≡]-intro))) (positive-congruence ctx)))
  ))
positive-congruence (conjunctionᵣ ctx) =
  [⟶]-intro ([⟶]-intro ([∧]-intro
    ([⟶]-elim ([∧]-elimₗ (direct (Right [≡]-intro))) ([⟶]-elim (direct (Left (Right [≡]-intro))) (positive-congruence ctx)))
    ([∧]-elimᵣ (direct (Right [≡]-intro)))
  ))
positive-congruence (disjunctionₗ ctx) =
  [⟶]-intro ([⟶]-intro ([∨]-elim
    ([∨]-introₗ (direct (Right [≡]-intro)))
    ([∨]-introᵣ ([⟶]-elim (direct (Right [≡]-intro)) ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (positive-congruence ctx))))
    (direct (Right [≡]-intro))
  ))
positive-congruence (disjunctionᵣ ctx) =
  [⟶]-intro ([⟶]-intro ([∨]-elim
    ([∨]-introₗ ([⟶]-elim (direct (Right [≡]-intro)) ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (positive-congruence ctx))))
    ([∨]-introᵣ (direct (Right [≡]-intro)))
    (direct (Right [≡]-intro))
  ))
positive-congruence (implicationₗ ctx) =
  [⟶]-intro ([⟶]-intro ([⟶]-intro ([⟶]-elim
    ([⟶]-elim (direct(Right [≡]-intro)) (direct (Left (Right [≡]-intro))))
    ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (positive-congruence ctx))
  )))
positive-congruence (implicationᵣ ctx) =
  [⟶]-intro ([⟶]-intro ([⟶]-intro ([⟶]-elim
    ([⟶]-elim (direct (Right [≡]-intro)) ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (negative-congruence ctx)))
    (direct (Left (Right [≡]-intro)))
  )))

negative-congruence (conjunctionₗ ctx) =
  [⟶]-intro ([⟶]-intro ([∧]-intro
    ([∧]-elimₗ (direct (Right [≡]-intro)))
    ([⟶]-elim ([∧]-elimᵣ (direct (Right [≡]-intro))) ([⟶]-elim (direct (Left (Right [≡]-intro))) (negative-congruence ctx)))
  ))
negative-congruence (conjunctionᵣ ctx) =
  [⟶]-intro ([⟶]-intro ([∧]-intro
    ([⟶]-elim ([∧]-elimₗ (direct (Right [≡]-intro))) ([⟶]-elim (direct (Left (Right [≡]-intro))) (negative-congruence ctx)))
    ([∧]-elimᵣ (direct (Right [≡]-intro)))
  ))
negative-congruence (disjunctionₗ ctx) =
  [⟶]-intro ([⟶]-intro ([∨]-elim
    ([∨]-introₗ (direct (Right [≡]-intro)))
    ([∨]-introᵣ ([⟶]-elim (direct (Right [≡]-intro)) ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (negative-congruence ctx))))
    (direct (Right [≡]-intro))
  ))
negative-congruence (disjunctionᵣ ctx) =
  [⟶]-intro ([⟶]-intro ([∨]-elim
    ([∨]-introₗ ([⟶]-elim (direct (Right [≡]-intro)) ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (negative-congruence ctx))))
    ([∨]-introᵣ (direct (Right [≡]-intro)))
    (direct (Right [≡]-intro))
  ))
negative-congruence (implicationₗ ctx) =
  [⟶]-intro ([⟶]-intro ([⟶]-intro ([⟶]-elim
    ([⟶]-elim (direct(Right [≡]-intro)) (direct (Left (Right [≡]-intro))))
    ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (negative-congruence ctx))
  )))
negative-congruence (implicationᵣ ctx) =
  [⟶]-intro ([⟶]-intro ([⟶]-intro ([⟶]-elim
    ([⟶]-elim (direct (Right [≡]-intro)) ([⟶]-elim (direct (Left (Left (Right [≡]-intro)))) (positive-congruence ctx)))
    (direct (Left (Right [≡]-intro)))
  )))

-- TODO: Mainly for results in minimal logic
data NegativeFragment {P : Type{ℓₚ}} : Formula(P) → Type{Lvl.of(P)} where
  atom   : NegativeFragment(¬(• p))
  bottom : NegativeFragment(⊥)
  top    : NegativeFragment(⊤)
  neg    : NegativeFragment(φ) → NegativeFragment(¬ φ)
  and    : NegativeFragment(φ) → NegativeFragment(ψ) → NegativeFragment(φ ∧ ψ)
  impl   : NegativeFragment(φ) → NegativeFragment(ψ) → NegativeFragment(φ ⟶ ψ)
  eq     : NegativeFragment(φ) → NegativeFragment(ψ) → NegativeFragment(φ ⟷ ψ)

open import Functional
open import Type.Dependent
open import Type.Dependent.Functions

module GGNegativeTranslation where
  trans : Formula(P) → Formula(P)
  trans (• p)   = ¬(¬(• p))
  trans ⊤       = ⊤
  trans ⊥       = ⊥
  trans (¬ φ)   = ¬(trans φ)
  trans (φ ∧ ψ) = (trans φ) ∧ (trans ψ)
  trans (φ ∨ ψ) = ¬((¬(trans φ)) ∧ (¬(trans ψ)))
  trans (φ ⟶ ψ) = (trans φ) ⟶ (trans ψ)
  trans (φ ⟷ ψ) = (trans φ) ⟷ (trans ψ)

  trans-negativeFragment : NegativeFragment(trans(φ))
  trans-negativeFragment {φ = • p}   = neg atom
  trans-negativeFragment {φ = ⊤}     = top
  trans-negativeFragment {φ = ⊥}     = bottom
  trans-negativeFragment {φ = ¬ φ}   = neg trans-negativeFragment
  trans-negativeFragment {φ = φ ∧ ψ} = and trans-negativeFragment trans-negativeFragment
  trans-negativeFragment {φ = φ ∨ ψ} = neg(and(neg trans-negativeFragment) (neg trans-negativeFragment))
  trans-negativeFragment {φ = φ ⟶ ψ} = impl trans-negativeFragment trans-negativeFragment
  trans-negativeFragment {φ = φ ⟷ ψ} = eq trans-negativeFragment trans-negativeFragment


module maybe-thms where

open import eq
open import level
open import maybe
open import product
open import sum

maybe-dec : ∀ {ℓ}{A : Set ℓ}(x : maybe A) → x ≡ nothing ∨ Σ A (λ a → x ≡ just a)
maybe-dec nothing = inj₁ refl
maybe-dec (just a) = inj₂ (a , refl)


module Container.Bag where

open import Prelude

Bag : Set → Set
Bag A = List (Nat × A)

FunctorBag : Functor Bag
fmap {{FunctorBag}} f b = map (second f) b

union : {A : Set} {{OrdA : Ord A}} → Bag A → Bag A → Bag A
union a [] = a
union [] b = b
union ((i , x) ∷ a) ((j , y) ∷ b) with compare x y
... | less    _ = (i , x) ∷ union a ((j , y) ∷ b)
... | equal   _ = (i + j , x) ∷ union a b
... | greater _ = (j , y) ∷ union ((i , x) ∷ a) b


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.CommRing.Integers where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.CommRing

module _ where
  open import Cubical.HITs.Ints.BiInvInt
    renaming (
      _+_ to _+ℤ_;
      -_ to _-ℤ_;
      +-assoc to +ℤ-assoc;
      +-comm to +ℤ-comm
    )

  BiInvIntAsCommRing : CommRing {ℓ-zero}
  BiInvIntAsCommRing =
    makeCommRing
      zero (suc zero) _+ℤ_ _·_ _-ℤ_
      isSetBiInvInt
      +ℤ-assoc +-zero +-invʳ +ℤ-comm
      ·-assoc ·-identityʳ
      (λ x y z → sym (·-distribˡ x y z))
      ·-comm

-- makeCommRing ? ? ? ? ? ? ? ? ? ? ? ? ? ?

module _ where
  open import Cubical.Data.Int

  IntAsCommRing : CommRing {ℓ-zero}
  IntAsCommRing = makeCommRing {R = Int} 0 1 _+_ _·_ -_ isSetInt
    +-assoc +-identityʳ +-inverseʳ +-comm (λ x y z → sym (·-assoc x y z)) ·-identityʳ
    (λ x y z → sym (·-distribˡ x y z)) ·-comm

module _ where
  open import Cubical.HITs.Ints.QuoInt

  QuoIntAsCommRing : CommRing {ℓ-zero}
  QuoIntAsCommRing = makeCommRing {R = ℤ} 0 1 _+_ _·_ -_ isSetℤ
    +-assoc +-identityʳ +-inverseʳ +-comm ·-assoc ·-identityʳ
    (λ x y z → sym (·-distribˡ x y z)) ·-comm

module _ where
  open import Cubical.Data.DiffInt

  DiffIntAsCommRing : CommRing {ℓ-zero}
  DiffIntAsCommRing = makeCommRing {R = ℤ} 0 1 _+_ _·_ -_ isSetℤ
    +-assoc +-identityʳ +-inverseʳ +-comm ·-assoc ·-identityʳ ·-distribˡ ·-comm

open import Cubical.Algebra.Ring using (ringequiv)
open import Cubical.Foundations.Equiv
open import Cubical.Reflection.Base using (_$_) -- TODO: add this to Foundation.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Structure
open import Cubical.HITs.Ints.BiInvInt using (BiInvInt)
open import Cubical.Data.Nat using (suc; zero) renaming (_·_ to _·ⁿ_; _+_ to _+ⁿ_)
open import Cubical.Data.Int as Int using (sucInt; predInt; Int) renaming
  ( _+_ to _+'_
  ; _·_ to _·'_
  ; -_ to -'_
  ; pos to pos'
  ; negsuc to negsuc'
  ; sgn to sgn'
  ; abs to abs'
  ; signed to signed'
  )

module _ where
  open import Cubical.HITs.Ints.BiInvInt renaming
    ( fwd to ⟦_⟧
    ; suc to sucᵇ
    )

  private
    suc-⟦⟧ : ∀ x → sucᵇ ⟦ x ⟧ ≡ ⟦ sucInt x ⟧
    suc-⟦⟧ (pos' n) = refl
    suc-⟦⟧ (negsuc' zero) = suc-pred _
    suc-⟦⟧ (negsuc' (suc n)) = suc-pred _

    pred-⟦⟧ : ∀ x → predl ⟦ x ⟧ ≡ ⟦ predInt x ⟧
    pred-⟦⟧ (pos' zero) = refl
    pred-⟦⟧ (pos' (suc n)) = pred-suc _
    pred-⟦⟧ (negsuc' zero) = refl
    pred-⟦⟧ (negsuc' (suc n)) = refl

    neg-⟦⟧ : ∀ x → - ⟦ x ⟧ ≡ ⟦ -' x ⟧
    neg-⟦⟧ (pos' zero) = refl
    neg-⟦⟧ (pos' (suc n)) = (λ i → predl (neg-⟦⟧ (pos' n) i)) ∙ pred-⟦⟧ (-' pos' n) ∙ cong ⟦_⟧ (Int.predInt-neg (pos' n))
    neg-⟦⟧ (negsuc' zero) = refl
    neg-⟦⟧ (negsuc' (suc n)) = (λ i → sucᵇ (neg-⟦⟧ (negsuc' n) i))

    pres1 : 1 ≡ ⟦ 1 ⟧
    pres1 = refl

    isHom+ : ∀ x y → ⟦ x +' y ⟧ ≡ ⟦ x ⟧ + ⟦ y ⟧
    isHom+ (pos' zero) y i = ⟦ Int.+-comm 0 y i ⟧
    isHom+ (pos' (suc n)) y =
      ⟦ pos' (suc n) +' y ⟧     ≡[ i ]⟨ ⟦ Int.sucInt+ (pos' n) y (~ i) ⟧ ⟩
      ⟦ sucInt (pos' n +' y) ⟧  ≡⟨ sym $ suc-⟦⟧ _ ⟩
      sucᵇ  ⟦ pos' n +' y ⟧     ≡[ i ]⟨ sucᵇ $ isHom+ (pos' n) y i ⟩
      sucᵇ (⟦ pos' n ⟧ + ⟦ y ⟧) ≡⟨ refl ⟩
      sucᵇ  ⟦ pos' n ⟧ + ⟦ y ⟧  ∎
    isHom+ (negsuc' zero) y = pred-suc-inj _ _ (λ i → predl (γ i)) where
      -- γ =   sucᵇ ⟦  negsuc' zero +' y ⟧  ≡⟨ suc-⟦⟧ (negsuc' zero +' y) ⟩
      --     ⟦ sucInt (negsuc' zero +' y)⟧  ≡⟨ cong ⟦_⟧ $ Int.sucInt+ (negsuc' zero) y ∙ Int.+-comm 0 y ⟩
      --                       ⟦       y ⟧  ≡⟨ sym (suc-pred ⟦ y ⟧) ⟩
      --     sucᵇ (pred zero + ⟦       y ⟧) ∎
      γ = suc-⟦⟧ (negsuc' zero +' y) ∙ (λ i → ⟦ (Int.sucInt+ (negsuc' zero) y ∙ Int.+-comm 0 y) i ⟧) ∙ sym (suc-pred ⟦ y ⟧)
    isHom+ (negsuc' (suc n)) y = (λ i → ⟦ Int.predInt+ (negsuc' n) y (~ i) ⟧) ∙ sym (pred-⟦⟧ (negsuc' n +' y))
                               ∙ (λ i → pred $ isHom+ (negsuc' n) y i)

    isHom· : ∀ x y → ⟦ x ·' y ⟧ ≡ ⟦ x ⟧ · ⟦ y ⟧
    isHom· (pos' zero) y i = ⟦ Int.signed-zero (Int.sgn y) i ⟧
    isHom· (pos' (suc n)) y =
      ⟦ pos' (suc n) ·' y ⟧      ≡⟨ cong ⟦_⟧ $ Int.·-pos-suc n y ⟩
      ⟦ y +' pos' n ·' y ⟧       ≡⟨ isHom+ y _ ⟩
      ⟦ y ⟧ + ⟦ pos' n ·' y ⟧    ≡[ i ]⟨ ⟦ y ⟧ + isHom· (pos' n) y i ⟩
      ⟦ y ⟧ + ⟦ pos' n ⟧ · ⟦ y ⟧ ≡⟨ (λ i → ⟦ y ⟧ + ·-comm ⟦ pos' n ⟧ ⟦ y ⟧ i)
                                  ∙ sym (·-suc ⟦ y ⟧ ⟦ pos' n ⟧) ∙ ·-comm ⟦ y ⟧ _ ⟩
      sucᵇ ⟦ pos' n ⟧ · ⟦ y ⟧ ∎
    isHom· (negsuc' zero) y =
      ⟦ -1 ·'  y ⟧ ≡⟨ cong ⟦_⟧ (Int.·-neg1 y) ⟩
      ⟦ -'     y ⟧ ≡⟨ sym (neg-⟦⟧ y) ⟩
        -    ⟦ y ⟧ ≡⟨ sym (·-neg1 ⟦ y ⟧) ⟩
        -1 · ⟦ y ⟧ ∎
    isHom· (negsuc' (suc n)) y =
      ⟦ negsuc' (suc n) ·' y ⟧         ≡⟨ cong ⟦_⟧ $ Int.·-negsuc-suc n y ⟩
      ⟦ -' y   +'  negsuc' n   ·'  y ⟧ ≡⟨ isHom+ (-' y) _ ⟩
      ⟦ -' y ⟧ + ⟦ negsuc' n   ·'  y ⟧ ≡[ i ]⟨ ⟦ -' y ⟧ + isHom· (negsuc' n) y i ⟩
      ⟦ -' y ⟧ + ⟦ negsuc' n ⟧ · ⟦ y ⟧ ≡⟨ cong₂ _+_ (sym (neg-⟦⟧ y)) refl ⟩
      -  ⟦ y ⟧ + ⟦ negsuc' n ⟧ · ⟦ y ⟧ ≡⟨ (λ i → - ⟦ y ⟧ + ·-comm ⟦ negsuc' n ⟧ ⟦ y ⟧ i)
                                        ∙ sym (·-pred ⟦ y ⟧ ⟦ negsuc' n ⟧) ∙ ·-comm ⟦ y ⟧ _ ⟩
      pred ⟦ negsuc' n ⟧ · ⟦ y ⟧       ∎

    ⟦⟧-isEquiv : isEquiv ⟦_⟧
    ⟦⟧-isEquiv = isoToIsEquiv (iso ⟦_⟧ bwd fwd-bwd bwd-fwd)

  Int≃BiInvInt-CommRingEquivΣ : Σ[ e ∈ ⟨ IntAsCommRing ⟩ ≃ ⟨ BiInvIntAsCommRing ⟩ ] CommRingEquiv IntAsCommRing BiInvIntAsCommRing e
  Int≃BiInvInt-CommRingEquivΣ .fst = ⟦_⟧ , ⟦⟧-isEquiv
  Int≃BiInvInt-CommRingEquivΣ .snd = ringequiv pres1 isHom+ isHom·

  Int≡BiInvInt-AsCommRing : IntAsCommRing ≡ BiInvIntAsCommRing
  Int≡BiInvInt-AsCommRing = CommRingPath _ _ .fst Int≃BiInvInt-CommRingEquivΣ

module _ where
  open import Cubical.HITs.Ints.QuoInt as QuoInt renaming
    ( Int→ℤ to ⟦_⟧
    )
  open import Cubical.Data.Bool

  private
    suc-⟦⟧ : ∀ x → sucℤ ⟦ x ⟧ ≡ ⟦ sucInt x ⟧
    suc-⟦⟧ (pos' n) = refl
    suc-⟦⟧ (negsuc' zero) = sym posneg
    suc-⟦⟧ (negsuc' (suc n)) = refl

    pred-⟦⟧ : ∀ x → predℤ ⟦ x ⟧ ≡ ⟦ predInt x ⟧
    pred-⟦⟧ (pos' zero) = refl
    pred-⟦⟧ (pos' (suc n)) = refl
    pred-⟦⟧ (negsuc' n) = refl

    neg-⟦⟧ : ∀ x → - ⟦ x ⟧ ≡ ⟦ -' x ⟧
    neg-⟦⟧ (pos' zero) = sym posneg
    neg-⟦⟧ (pos' (suc n)) = refl
    neg-⟦⟧ (negsuc' n) = refl

    pres1 : 1 ≡ ⟦ 1 ⟧
    pres1 = refl

    isHom+ : ∀ x y → ⟦ x +' y ⟧ ≡ ⟦ x ⟧ + ⟦ y ⟧
    isHom+ (pos' zero) y i = ⟦ Int.+-comm 0 y i ⟧
    isHom+ (pos' (suc n)) y =
      ⟦ pos' (suc n)   +' y  ⟧ ≡[ i ]⟨ ⟦ Int.sucInt+ (pos' n) y (~ i) ⟧ ⟩
      ⟦ sucInt (pos' n +' y) ⟧ ≡⟨ sym $ suc-⟦⟧ _ ⟩
      sucℤ  ⟦ pos' n   +' y  ⟧ ≡[ i ]⟨ sucℤ $ isHom+ (pos' n) y i ⟩
      sucℤ (⟦ pos' n ⟧ + ⟦ y ⟧) ≡⟨ refl ⟩
      sucℤ  ⟦ pos' n ⟧ + ⟦ y ⟧  ∎
    isHom+ (negsuc'  zero  ) y = sucℤ-inj _ _ (suc-⟦⟧ (negsuc' zero +' y)
                               ∙ (cong ⟦_⟧ $ Int.sucInt+ (negsuc' zero) y
                               ∙ Int.+-identityˡ y)
                               ∙ sym (sucPredℤ ⟦ y ⟧))
    isHom+ (negsuc' (suc n)) y = cong ⟦_⟧ (sym (Int.predInt+ (negsuc' n) y))
                               ∙ (sym $ pred-⟦⟧ (negsuc' n +' y))
                               ∙ (λ i → predℤ $ isHom+ (negsuc' n) y i)

    isHom· : ∀ x y → ⟦ x ·' y ⟧ ≡ ⟦ x ⟧ · ⟦ y ⟧
    isHom· (pos' zero) y = (cong ⟦_⟧ $ Int.signed-zero (sgn' y)) ∙ sym (signed-zero (sign ⟦ y ⟧) spos)
    isHom· (pos' (suc n)) y =
      ⟦ pos' (suc n)     ·'  y ⟧ ≡⟨ cong ⟦_⟧ $ Int.·-pos-suc n y ⟩
      ⟦ y   +'  pos' n   ·'  y ⟧ ≡⟨ isHom+ y _ ⟩
      ⟦ y ⟧ + ⟦ pos' n   ·'  y ⟧ ≡[ i ]⟨ ⟦ y ⟧ + isHom· (pos' n) y i ⟩
      ⟦ y ⟧ + ⟦ pos' n ⟧ · ⟦ y ⟧ ≡⟨ sym $ ·-pos-suc n ⟦ y ⟧ ⟩
      sucℤ ⟦ pos' n ⟧ · ⟦ y ⟧ ∎
    isHom· (negsuc' zero) y =
      ⟦ -1 ·'  y ⟧ ≡⟨ cong ⟦_⟧ (Int.·-neg1 y) ⟩
      ⟦ -'     y ⟧ ≡⟨ sym (neg-⟦⟧ y) ⟩
        -    ⟦ y ⟧ ≡⟨ sym (·-neg1 ⟦ y ⟧) ⟩
        -1 · ⟦ y ⟧ ∎
    isHom· (negsuc' (suc n)) y =
      ⟦ negsuc' (suc n) ·' y ⟧         ≡⟨ cong ⟦_⟧ $ Int.·-negsuc-suc n y ⟩
      ⟦ -' y   +'  negsuc' n   ·'  y ⟧ ≡⟨ isHom+ (-' y) _ ⟩
      ⟦ -' y ⟧ + ⟦ negsuc' n   ·'  y ⟧ ≡[ i ]⟨ ⟦ -' y ⟧ + isHom· (negsuc' n) y i ⟩
      ⟦ -' y ⟧ + ⟦ negsuc' n ⟧ · ⟦ y ⟧ ≡⟨ cong₂ _+_ (sym (neg-⟦⟧ y)) refl ⟩
      -  ⟦ y ⟧ + ⟦ negsuc' n ⟧ · ⟦ y ⟧ ≡⟨ sym (·-neg-suc (suc n) ⟦ y ⟧) ⟩
      predℤ ⟦ negsuc' n ⟧ · ⟦ y ⟧      ∎

    ⟦⟧-isEquiv : isEquiv ⟦_⟧
    ⟦⟧-isEquiv = isoToIsEquiv (iso ⟦_⟧ ℤ→Int ℤ→Int→ℤ Int→ℤ→Int)

  Int≃QuoInt-CommRingEquivΣ : Σ[ e ∈ ⟨ IntAsCommRing ⟩ ≃ ⟨ QuoIntAsCommRing ⟩ ] CommRingEquiv IntAsCommRing QuoIntAsCommRing e
  Int≃QuoInt-CommRingEquivΣ .fst = ⟦_⟧ , ⟦⟧-isEquiv
  Int≃QuoInt-CommRingEquivΣ .snd = ringequiv pres1 isHom+ isHom·

  Int≡QuoInt-AsCommRing : IntAsCommRing ≡ QuoIntAsCommRing
  Int≡QuoInt-AsCommRing = CommRingPath _ _ .fst Int≃QuoInt-CommRingEquivΣ

QuoInt≡BiInvInt-AsCommRing : QuoIntAsCommRing ≡ BiInvIntAsCommRing
QuoInt≡BiInvInt-AsCommRing = sym Int≡QuoInt-AsCommRing ∙ Int≡BiInvInt-AsCommRing

open import Cubical.HITs.SetQuotients

module _ where
  open import Cubical.Data.Sigma
  open import Cubical.Data.Bool
  open import Cubical.Data.Nat using (ℕ) renaming (_·_ to _·ⁿ_)
  open import Cubical.HITs.Rationals.QuoQ using (ℚ) renaming (_+_ to _+ʳ_)
  open import Cubical.HITs.Ints.QuoInt using (ℤ; sign; signed; abs) renaming (_+_ to _+ᶻ_)
  open import Cubical.Data.NatPlusOne using (ℕ₊₁; 1+_)

  test1 : ℤ → _
  test1 x = {! x +ᶻ x  !}
  -- Normal form:
  --   x +ᶻ x

  test2 : ℤ × ℕ₊₁  → _
  test2 x = {! [ x ] +ʳ [ x ]  !}
  -- Normal form:
  --   [  signed (sign (fst x) ⊕ false) (abs (fst x) ·ⁿ suc (ℕ₊₁.n (snd x)))
  --   +ᶻ signed (sign (fst x) ⊕ false) (abs (fst x) ·ⁿ suc (ℕ₊₁.n (snd x)))
  --   , (1+ (ℕ₊₁.n (snd x) +ⁿ ℕ₊₁.n (snd x) ·ⁿ suc (ℕ₊₁.n (snd x))))
  --   ]

  test3 : ℚ → ℤ × ℕ₊₁  → _
  test3 x y = {! x +ʳ [ y ]  !}
  -- Normal form:
  --   rec
  --   (λ f g F G i j z →
  --      squash/ (f z) (g z) (λ i₁ → F i₁ z) (λ i₁ → G i₁ z) i j)
  --   (λ a → ...
  --     ...
  --   ... 2000 more lines ...

open import Cubical.Data.DiffInt as DiffInt hiding (_+'_; _·'_)

⟦⟧-isEquiv : isEquiv ⟦_⟧
⟦⟧-isEquiv = isoToIsEquiv (iso ⟦_⟧ bwd fwd-bwd bwd-fwd)

pres1 : 1 ≡ ⟦ 1 ⟧
pres1 = refl

isHom+ : ∀ x y → ⟦ x +' y ⟧ ≡ ⟦ x ⟧ + ⟦ y ⟧
isHom+ (pos' zero) y = {!   !}
isHom+ (pos' (suc n)) y = {!   !} -- ? ∙ λ i → sucℤ (isHom+ (pos' n) y i)
isHom+ (negsuc' zero) y = {! [ 0 , 1 ] + ⟦ y ⟧  !}
isHom+ (negsuc' (suc n)) y = {!   !}

isHom· : ∀ x y → ⟦ x ·' y ⟧ ≡ ⟦ x ⟧ · ⟦ y ⟧
isHom· = {!   !}

Int≃DiffInt-CommRingEquivΣ : Σ[ e ∈ ⟨ IntAsCommRing ⟩ ≃ ⟨ DiffIntAsCommRing ⟩ ] CommRingEquiv IntAsCommRing DiffIntAsCommRing e
Int≃DiffInt-CommRingEquivΣ .fst = ⟦_⟧ , ⟦⟧-isEquiv
Int≃DiffInt-CommRingEquivΣ .snd = ringequiv pres1 isHom+ isHom·

Int≡DiffInt-AsCommRing : IntAsCommRing ≡ DiffIntAsCommRing
Int≡DiffInt-AsCommRing = CommRingPath _ _ .fst Int≃DiffInt-CommRingEquivΣ

DiffInt≡BiInvInt-AsCommRing : DiffIntAsCommRing ≡ BiInvIntAsCommRing
DiffInt≡BiInvInt-AsCommRing = sym Int≡DiffInt-AsCommRing ∙ Int≡BiInvInt-AsCommRing


-- Andreas, 2012-01-10
-- {-# OPTIONS -v tc.constr.findInScope:50 #-}
module InstanceGuessesMeta where

data Bool : Set where
  true false : Bool

postulate
  D : Bool -> Set
  E : Bool -> Set
  d : {x : Bool} -> D x
  f : {x : Bool}{{ dx : D x }} -> E x

b : E true
b = f  -- should succeed
-- Agda is now allowed to solve hidden x in type of d by unification,
-- when searching for inhabitant of D x


-- Andreas, 2016-06-01, issue 1997 reported by Andres

{-# OPTIONS --rewriting #-}

infix  4 _≡_
infixl 6 _+_

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x

{-# BUILTIN REWRITE _≡_ #-}

cong : ∀ {a b} {A : Set a} {B : Set b}
       (f : A → B) {x y} → x ≡ y → f x ≡ f y
cong f refl = refl

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

_+_ : ℕ → ℕ → ℕ
zero  + m = m
suc n + m = suc (n + m)

plus0 : (x : ℕ) → x + zero ≡ x
plus0 zero    = refl
plus0 (suc x) = cong suc (plus0 x)

{-# REWRITE plus0 #-}
{-# REWRITE plus0 #-}

-- Should complain about duplicate rewrite rule


module Data.Lens.Proofs.LensLaws where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Agda.Primitive

-- First, define the lens laws

ViewSet : {a b : Set} -> (l : Lens a b) -> Set
ViewSet {a} {b} l = (v : b) (s : a) -> view l (set l v s) ≡ v

SetView : {a b : Set} -> (l : Lens a b) -> Set
SetView {a} {b} l = (s : a) -> set l (view l s) s ≡ s

SetSet : {a b : Set} -> (l : Lens a b) -> Set
SetSet {a} {b} l = (v1 v2 : b) (s : a) -> set l v2 (set l v1 s) ≡ set l v2 s

-- Define ValidLens as a lens for which the laws hold

data ValidLens (a b : Set) : Set₁ where
  CValidLens : (l : Lens a b) -> ViewSet l -> SetView l -> SetSet l -> ValidLens a b

toLens : ValidLens a b -> Lens a b
toLens (CValidLens l _ _ _) = l


{-# OPTIONS --sized-types #-}
-- {-# OPTIONS -v tc.size.solve:20 -v tc.decl.ax:10 #-}
module SizeUnsolvedConstraintsInTypeSignature where

open import Common.Size

data Nat : (i : Size) -> Set where
  Z : {i : Size} -> Nat (↑ i)
  S : {i : Size} -> Nat i → Nat (↑ i)

one1 : (i : Size) → Nat (↑ (↑ i))
one1 i = S Z

one2 : (i : Size) → Nat (↑ (↑ (↑ i)))
one2 i = S Z

postulate
  _≡_   : {A : Set} → A → A → Set
  works : (i : Size) → one2 i ≡ one1 i

  bug   : (i : Size) → one1 i ≡ one2 i
  -- bug caused an interal error due to absense of range info
  -- should not print a proper error message (or better, work!)


{-# OPTIONS --rewriting #-}

open import Agda.Primitive

postulate
  _↦_ : ∀{i j}{A : Set i}{B : Set j} → A → B → Set (i ⊔ j)

{-# BUILTIN REWRITE _↦_ #-}  -- currently fails a sanity check

postulate
  resize : ∀{i j} → Set i → Set j
  resize-id : ∀{i} {j} {A : Set i} → resize {i} {j} A ↦ A

{-# REWRITE resize-id #-}

-- Impredicative quantification

Forall : ∀{i} (F : Set i → Set) → Set
Forall {i} F = resize ((X : Set i) → F X)

-- Example: Impredicative encoding of natural numbers

Nat = Forall λ X → (X → X) → X → X

zero : Nat
zero X s z = z

suc : Nat → Nat
suc n X s z = s (n X s z)

-- requires impredicativity:

id : Nat → Nat
id n = n Nat suc zero


data Nat : Set where
  succ : Nat → Nat

data Fin : Nat → Set where
  zero : (n : Nat) → Fin (succ n)

data Tm (n : Nat) : Set where
  var : Fin n → Tm n
  piv : Fin (succ n) → Tm n

data Cx : Nat → Set where
  succ : (n : Nat) → Tm n → Cx (succ n)

data CxChk : ∀ n → Cx n → Set where
  succ : (n : Nat) (T : Tm n) → CxChk (succ n) (succ n T)

data TmChk (n : Nat) : Cx n → Tm n → Set where
  vtyp : (g : Cx n) (v : Fin n) → CxChk n g → TmChk n g (var v)

error : ∀ n g s → TmChk n g s → Set
error n g s (vtyp g' (zero x) (succ n' (piv (zero y)))) =  Nat -- Internal error here.
error _ _ _ (vtyp g' (zero n) (succ n (var x))) = Nat -- This clause added to pass 2.5.3.