module Array.Base where

open import Data.Nat
open import Data.Nat.DivMod             --using (_div_ ; _mod_; _/_; m/n*n≤m)
open import Data.Nat.Divisibility
open import Data.Nat.Properties
open import Data.Vec
open import Data.Vec.Properties         using (lookup∘tabulate)
open import Data.Fin.Base               hiding (_<_; _+_)
open import Data.Fin.Properties         hiding (_≟_; <-cmp; ≤-trans; <-trans)
open import Function                    using (_$_; _∘_; case_of_)
open import Data.Product                using (Σ; _,_)
open import Relation.Binary.PropositionalEquality   --using (_≡_; _≢_; refl; subst; sym; cong; cong₂)
open import Relation.Binary
open import Relation.Binary.Core
open import Relation.Nullary            --using (Dec; yes; no)
open import Relation.Nullary.Decidable  --using (fromWitnessFalse; False)
open import Relation.Nullary.Negation   --using (contradiction)
open import Data.Sum                    using (inj₁; inj₂)
open import Data.Empty

infixr 5 _∷_
data Ix : (d : ℕ) → (s : Vec ℕ d) → Set where
  []   : Ix 0 []
  _∷_  : ∀ {d s x} → Fin x → (ix : Ix d s) → Ix (suc d) (x ∷ s)

ix-lookup : ∀ {d s} → Ix d s → (i : Fin d) → Fin (lookup s i)
ix-lookup [] ()
ix-lookup (x ∷ ix) zero = x
ix-lookup (x ∷ ix) (suc i) = ix-lookup ix i

ix-tabulate : ∀ {d s} → ((i : Fin d) → Fin (lookup s i)) → Ix d s
ix-tabulate {s = []} f = []
ix-tabulate {s = x ∷ s} f = f zero ∷ ix-tabulate (f ∘ suc)

ix→v : ∀ {d s} → Ix d s → Vec ℕ d
ix→v [] = []
ix→v (x ∷ xs) = toℕ x ∷ ix→v xs

--data Ar {a} (X : Set a) (d : ℕ) (s : Vec ℕ d) : Set a where
--  imap : (Ix d s → X) → Ar X d s
--
-- We used this type before `withReconstructed` was introduced, so that
-- we could obtain the shape of arrays at each imap.  Now we have switched
-- to the record that gives us η-equality.
--
--data Ar {a} (X : Set a) (d : ℕ) : (Vec ℕ d) → Set a where
--  imap : ∀ {s} → (Ix d s → X) → Ar X d s

record Ar {a} (X : Set a) (d : ℕ) (s : Vec ℕ d) : Set a where
  constructor imap
  field sel : Ix d s → X
open Ar public

unimap : ∀ {a}{X : Set a}{d s} → Ar X d s → Ix d s → X
unimap (imap x) = x

cst : ∀ {a}{X : Set a}{d s} → X → Ar X d s
cst x = imap λ _ → x

-- Promoting shapes into 1-dimensional array of integers
-- and back.
s→a : ∀ {n} → Vec ℕ n → Ar ℕ 1 (n ∷ [])
s→a s = imap (λ iv → lookup s $ ix-lookup iv zero )

a→s : ∀ {s} → Ar ℕ 1 (s ∷ []) → Vec ℕ s
a→s (imap x) = tabulate λ i → x (i ∷ [])

-- Here we define < on shape-like objects and demonstrate that
-- this relation is decideable.
_<s_ : ∀ {n} → Vec ℕ n → Vec ℕ n → Set
a <s b = ∀ i → lookup a i < lookup b i

-- XXX This might be just equality
_=s_ : ∀ {n} → Vec ℕ n → Vec ℕ n → Set
a =s b = ∀ i → lookup a i ≡ lookup b i

_<a_ : ∀ {d s} → Ar ℕ d s → Ar ℕ d s → Set
imap f <a imap g = ∀ iv → f iv < g iv

_≥a_ : ∀ {d s} → Ar ℕ d s → Ar ℕ d s → Set
imap f ≥a imap g = ∀ iv → f iv ≥ g iv

_=a_ : ∀ {a}{X : Set a}{d s} → Ar X d s → Ar X d s → Set a
imap f =a imap g = ∀ iv → f iv ≡ g iv

_=ix_ : ∀ {d s} → Ix d s → Ix d s → Set
iv =ix jv = ∀ i → ix-lookup iv i ≡ ix-lookup jv i

subst-ix : ∀ {n}{s s₁ : Vec ℕ n} → s =s s₁ → Ix n s → Ix n s₁
subst-ix {zero} {[]} {[]} pf []  = []
subst-ix {suc n} {x ∷ xs} {y ∷ ys} pf (i ∷ iv) rewrite (pf zero) = i ∷ subst-ix (pf ∘ suc) iv

subst-ar : ∀ {a}{X : Set a}{n}{s s₁ : Vec ℕ n} → s =s s₁ → Ar X n s → Ar X n s₁
subst-ar pf (imap f) = imap λ iv → f $ subst-ix (sym ∘ pf) iv

subst-ar-d : ∀ {a}{X : Set a}{n m}{s : Vec ℕ n}{s₁ : Vec ℕ m}
           → (n=m : n ≡ m)
           → s =s (subst (Vec ℕ) (sym n=m) s₁)
           → Ar X n s → Ar X m s₁
subst-ar-d refl pf a = subst-ar pf a

-- If we have an index, produce a pair containing an array representation
-- and the proof that the index is smaller than the shape.
ix→a : ∀ {d}{s : Vec ℕ d}
     → (ix : Ix d s)
     → Σ (Ar ℕ 1 (d ∷ [])) λ ax → ax <a (s→a s)
ix→a ix = imap (λ iv → toℕ $ ix-lookup ix (ix-lookup iv zero)) ,
          λ iv → toℕ<n (ix-lookup ix (ix-lookup iv zero))

-- XXX we can do this via imap/lookup if we want to, so that it
-- extracts to more efficient code.
infixl 10 _ix++_
_ix++_ : ∀ {n m s s₁}
       → (iv : Ix n s)
       → (jv : Ix m s₁)
       → Ix (n + m) (s ++ s₁)
_ix++_ {s = []}     {s₁} iv jv = jv
_ix++_ {s = s ∷ ss} {s₁} (i ∷ iv) jv = i ∷ iv ix++ jv

nest : ∀ {a}{X : Set a}{n m s s₁}
     →  Ar X (n + m) (s ++ s₁)
     →  Ar (Ar X m s₁) n s
nest (imap f) = imap (λ iv → imap (λ jv → f (iv ix++ jv)))

-- Take and drop for indices
take-ix-l : ∀ {n m} → (s : Vec ℕ n) (s₁ : Vec ℕ m)
          → Ix (n + m) (s ++ s₁)
          → Ix n s
take-ix-l []       s₁ ix = []
take-ix-l (s ∷ ss) s₁ (x ∷ ix) = x ∷ take-ix-l ss s₁ ix

take-ix-r : ∀ {n m} → (s : Vec ℕ n) (s₁ : Vec ℕ m)
          → Ix (n + m) (s ++ s₁)
          → Ix m s₁
take-ix-r [] s₁ ix = ix
take-ix-r (x ∷ s) s₁ (x₁ ∷ ix) = take-ix-r s s₁ ix

-- Flatten the first nesting of the Ar
flatten : ∀ {a}{X : Set a}{n m}{s : Vec ℕ n}{s₁ : Vec ℕ m}
        → Ar (Ar X m s₁) n s
        → Ar X (n + m) (s ++ s₁)
flatten (imap f) = imap λ iv → case f (take-ix-l _ _ iv) of λ where
                              (imap g) → g (take-ix-r _ _ iv)

prod : ∀ {n} → (Vec ℕ n) → ℕ
prod s = foldr _ _*_ 1 s

magic-fin : ∀ {a}{X : Set a} → Fin 0 → X
magic-fin ()

a*b≢0⇒a≢0 : ∀ {a b} → a * b ≢ 0 → a ≢ 0
a*b≢0⇒a≢0 {zero}    {b} 0≢0 0≡0 = 0≢0 0≡0
a*b≢0⇒a≢0 {(suc a)} {b} _       = λ ()

a*b≢0⇒b≢0 : ∀ {a b} → a * b ≢ 0 → b ≢ 0
a*b≢0⇒b≢0 {a} {b} rewrite (*-comm a b) = a*b≢0⇒a≢0

-- A basic fact about division that is not yet in the stdlib.
/-mono-x : ∀ {a b c} → a < b * c → (c≢0 : False (c ≟ 0))
         → (a / c) {≢0 = c≢0} < b
/-mono-x {a}{b}{c} a<b*c c≢0 with <-cmp ((a / c) {≢0 = c≢0}) b
/-mono-x {a} {b} {c} a<b*c c≢0 | tri< l< _ _ = l<
/-mono-x {a} {b} {c} a<b*c c≢0 | tri≈ _ l≡ _ = let
     a<a/c*c = subst (a <_) (cong₂ _*_ (sym l≡) refl) a<b*c
     a/c*c≤a = m/n*n≤m a c {≢0 = c≢0}
     a<a = ≤-trans a<a/c*c a/c*c≤a
   in contradiction a<a (n≮n a)
/-mono-x {a} {b} {suc c} a<b*c c≢0 | tri> _ _ l> = let
     b*c<a/c*c = *-monoˡ-< c l>
     a/c*c≤a = m/n*n≤m a (suc c) {≢0 = c≢0}
     b*c≤a = ≤-trans b*c<a/c*c a/c*c≤a
     a<a = <-trans a<b*c b*c≤a
   in contradiction a<a (n≮n a)

/-mono-f : ∀ {a b c} → a < b * c → (b≢0 : False (b ≟ 0))
         → (a / b) {≢0 = b≢0} < c
/-mono-f {b = b}{c} a<b*c ≢0 rewrite *-comm b c = /-mono-x a<b*c ≢0

divmod-thm : ∀ {a b m n}
           → (n≢0 : n ≢ 0)
           → a ≡ (m % n) {≢0 = fromWitnessFalse n≢0}
           → b ≡ (m / n) {≢0 = fromWitnessFalse n≢0} * n
             → m ≡ a + b
divmod-thm {n = zero} n≢0 _ _ = contradiction refl n≢0
divmod-thm {m = m}{n = suc n} n≢0 refl refl = m≡m%n+[m/n]*n m n

-- XXX currently this is not efficient way to convert between indices and
-- offsets, as we are doing it form left to right.  Computing in reverse
-- makes more sense.  Something for later.

off→idx : ∀ {n} → (sh : Vec ℕ n)
        → Ix 1 (prod sh ∷ [])
        → Ix n sh
off→idx [] iv = []
off→idx (s ∷ sh) iv with prod (s ∷ sh) ≟ 0
off→idx (s ∷ sh) iv | yes p rewrite p = magic-fin $ ix-lookup iv zero
off→idx (s ∷ sh) (off ∷ []) | no ¬p = let
                                         o = toℕ off
                                         tl = prod sh
                                         tl≢0 = fromWitnessFalse (a*b≢0⇒b≢0 {a = s} ¬p)
                                     in {- off / tl -} (fromℕ< (/-mono-x (toℕ<n off) tl≢0))
                                        {- rec call -} ∷ (off→idx sh ((o mod tl) {tl≢0} ∷ []))

module test-oi where
  open import Data.Fin using (#_)
  test-oi₁ : off→idx (10 ∷ 5 ∷ []) (# 40 ∷ []) ≡ (# 8) ∷ (# 0) ∷ []
  test-oi₁ = refl

-- [x , y] < [a , b] ⇒ rowmaj [x , y] < a*b ⇒ x*b+y < a*b
rm-thm : ∀ {a b} → (x : Fin a) → (b ≢ 0) → (y : Fin b) → ((toℕ y) + (toℕ x) * b  < (a * b))
rm-thm {a} {ℕ.zero}  x pf y = contradiction (refl {x = 0}) pf
rm-thm {ℕ.zero} {ℕ.suc b₁} () pf y
rm-thm {ℕ.suc a₁} {ℕ.suc b₁} x pf y = +-mono-≤ (toℕ<n y) $ *-monoˡ-≤ (ℕ.suc b₁) (≤-pred $ toℕ<n x)

v-rm-thm : ∀ {a b x y b≢0} → (toℕ $ fromℕ< (rm-thm {a = a} {b = b} x b≢0 y)) ≡ (toℕ y) + (toℕ x) * b
v-rm-thm {suc a} {suc b} {x} {y} {≢0} = toℕ-fromℕ< (rm-thm x ≢0 y)

Πs≡0⇒Fin0 : ∀ {n} → (s : Vec ℕ n)
          → (Ix n s) → (prod s ≡ 0)
          → Fin 0
Πs≡0⇒Fin0 (x ∷ s) (i ∷ iv) Πxs≡0 with  m*n≡0⇒m≡0∨n≡0 x Πxs≡0
Πs≡0⇒Fin0 (x ∷ s) (i ∷ iv) Πxs≡0 | inj₁ x≡0 rewrite x≡0 = i
Πs≡0⇒Fin0 (x ∷ s) (i ∷ iv) Πxs≡0 | inj₂ Πs≡0 = Πs≡0⇒Fin0 s iv Πs≡0

idx→off : ∀ {n} → (s : Vec ℕ n)
        → (iv : Ix n s)
        → Ix 1 (prod s ∷ [])
idx→off [] iv = zero ∷ iv
idx→off (s ∷ sh) (i ∷ iv) with prod (s ∷ sh) ≟ 0
idx→off (s ∷ sh) (i ∷ iv) | yes p rewrite p = magic-fin $ Πs≡0⇒Fin0 (s ∷ sh) (i ∷ iv) p
idx→off (s ∷ sh) (i ∷ iv) | no ¬p = fromℕ< (rm-thm i (a*b≢0⇒b≢0 {a = s} ¬p) (ix-lookup (idx→off sh iv) zero)) ∷ []

module test-io where
  open import Data.Fin using (#_)
  test-io₁ : idx→off (10 ∷ 5 ∷ []) (# 8 ∷ # 0 ∷ []) ≡ # 40 ∷ []
  test-io₁ = refl

mkempty : ∀ {a}{X : Set a}{n} → (s : Vec ℕ n) → (prod s ≡ 0) → Ar X n s
mkempty {X = X} {n = n} s Πs≡0 = imap empty
  where
    empty : _
    empty iv = magic-fin $ Πs≡0⇒Fin0 s iv Πs≡0

-- Fin fact:
Fin1≡0 : (x : Fin 1) → x ≡ zero
Fin1≡0 zero = refl

-- XXX This should be moved to Properties
io-oi : ∀ {n}{x : Vec _ n}{i : Fin (prod x)}
      → idx→off x (off→idx x (i ∷ [])) ≡ i ∷ []
io-oi {zero} {[]}{i} = cong (_∷ []) (sym (Fin1≡0 i))
io-oi {suc n} {x ∷ x₁}{i} with prod (x ∷ x₁) ≟ 0
... | yes p = ⊥-elim $ ¬Fin0 (subst Fin p i)
... | no ¬p with prod (x ∷ x₁) ≟ 0
io-oi {suc n} {x ∷ x₁} {i} | no ¬p | yes q = contradiction q ¬p
io-oi {suc n} {x ∷ x₁} {i} | no ¬p | no ¬q
  = cong (_∷ []) (toℕ-injective (trans (v-rm-thm {a = x} {b = prod x₁})
                                       (sym (divmod-thm
                                                 {a = toℕ (ix-lookup (idx→off x₁ (off→idx x₁ _)) zero)}
                                                 (a*b≢0⇒b≢0 {a = x} ¬p)
                                                 (trans (cong (λ x → toℕ (ix-lookup x zero))
                                                              (io-oi {x = x₁}))
                                                        mod⇒%)
                                                 (mono⇒/* {b = x} {c = prod x₁})))))
  where
    mono⇒/* : ∀ {b c}{i : Fin (b * c)}{≢0 : False (c ≟ 0)}
            → toℕ {n = b} (fromℕ< (/-mono-x (toℕ<n i) (≢0))) * c ≡ (toℕ i / c) {≢0} * c
    mono⇒/* {b} {c} {i} {≢0} = cong (_* c) (toℕ-fromℕ< (/-mono-x (toℕ<n i) ≢0))

    mod⇒% :  ∀ {n}{i : Fin n}{a}{≢0 : False (a ≟ 0)} → toℕ ((toℕ i mod a){≢0}) ≡ (toℕ i % a) {≢0}
    mod⇒% {n} {i} {suc a} = trans (toℕ-fromℕ< (m%n<n (toℕ i) a)) refl

m≡m+x⇒0≡x : ∀ {m x} → m ≡ m + x → 0 ≡ x
m≡m+x⇒0≡x {m}{x} m≡m+x = +-cancelˡ-≡ m (trans (+-identityʳ m) m≡m+x)

a*b≡0⇒b≢0⇒a≡0 : ∀ {a b} → a * b ≡ 0 → b ≢ 0 → a ≡ 0
a*b≡0⇒b≢0⇒a≡0 {a}{b} a*b≡0 b≢0 with (m*n≡0⇒m≡0∨n≡0 a a*b≡0)
a*b≡0⇒b≢0⇒a≡0 {a} {b} a*b≡0 b≢0 | inj₁ x = x
a*b≡0⇒b≢0⇒a≡0 {a} {b} a*b≡0 b≢0 | inj₂ y = contradiction y b≢0

-- m≤n⇒m%n≡m
m<n⇒m/n≡0 : ∀ {m n} → (m<n : m < n) → ∀ {≢0} → (m / n) {≢0} ≡ 0
m<n⇒m/n≡0 {m} {n@(suc n-1)} m<n = let
                      m%n≡m = m≤n⇒m%n≡m (≤-pred m<n)
                      m≡m%n+m/n*n = (m≡m%n+[m/n]*n m n-1)
                      m≡m+m/n*n = trans m≡m%n+m/n*n (cong₂ _+_ m%n≡m refl)
                      m/n*n≡0 = sym (m≡m+x⇒0≡x m≡m+m/n*n)
                      m/n≡0 = a*b≡0⇒b≢0⇒a≡0 {a = m / n} {b = n} m/n*n≡0 (m<n⇒n≢0 m<n)
                    in m/n≡0

b≡0+c≡a⇒b+c≡a : ∀ {a b c} → b ≡ 0 → c ≡ a → b + c ≡ a
b≡0+c≡a⇒b+c≡a refl refl = refl

a<c⇒c|b⇒[a+b]%c≡a : ∀ {a b c} → a < c → (c ∣ b) → ∀ {≢0} → ((a + b) % c) {≢0} ≡ a
a<c⇒c|b⇒[a+b]%c≡a {a} {b} {c@(suc c-1)} a<c c|b = trans (%-remove-+ʳ a c|b) (m≤n⇒m%n≡m (≤-pred a<c))

a<c⇒c|b⇒[a+b]mod[c]≡a : ∀ {b c} → (a : Fin c) → (c ∣ b) → ∀ {≢0} → ((toℕ a + b) mod c) {≢0} ≡ a
a<c⇒c|b⇒[a+b]mod[c]≡a {b} {suc c-1} a c|b {≢0} = toℕ-injective (trans (toℕ-fromℕ< _) (a<c⇒c|b⇒[a+b]%c≡a (toℕ<n a) c|b))

ixl-cong : ∀ {s}{i : Ix 1 (s ∷ [])} → (ix-lookup i zero) ∷ [] ≡ i
ixl-cong {i = i ∷ []} = refl

--rm-thm : ∀ {a b} → (x : Fin a) → (b ≢ 0) → (y : Fin b) → ((toℕ y) + (toℕ x) * b  < (a * b))
--v-rm-thm : ∀ {a b x y b≢0} → (toℕ $ fromℕ< (rm-thm {a = a} {b = b} x b≢0 y)) ≡ (toℕ y) + (toℕ x) * b
oi-io : ∀ {n}{x : Vec _ n}{iv : Ix n x}
      → off→idx x (idx→off x iv) ≡ iv
oi-io {x = []} {[]} = refl
oi-io {x = x ∷ xs} {i ∷ iv} with prod (x ∷ xs) ≟ 0
... | yes p = ⊥-elim $ ¬Fin0 $ Πs≡0⇒Fin0 (x ∷ xs) (i ∷ iv) p
... | no ¬p = cong₂ _∷_
                   -- Πiv + i * Πxs
                   (toℕ-injective (trans (toℕ-fromℕ< _)
                                         (trans (cong (_/ prod xs) (toℕ-fromℕ< _))
                                                (hlpr {n = prod xs}
                                                      {a = toℕ (ix-lookup (idx→off xs iv) zero)}
                                                      refl (toℕ<n _)))))
                   (trans (cong (off→idx xs)
                                (trans (cong (λ x → x mod (prod xs) ∷ []) (toℕ-fromℕ< _))
                                       (trans (cong (_∷ []) (a<c⇒c|b⇒[a+b]mod[c]≡a _ (n∣m*n (toℕ i) {n = (prod xs)})))
                                              ixl-cong)))
                          oi-io)
   where
     hlpr : ∀ {m n a x}{≢0} → a + m * n ≡ x → a < n → (x / n) {≢0} ≡ m
     hlpr {m} {n} {a} {x} {≢0} refl a<n = trans (+-distrib-/-∣ʳ {m = a} (m * n) {d = n} {≢0} (n∣m*n m))
                                                (b≡0+c≡a⇒b+c≡a (m<n⇒m/n≡0 a<n) (m*n/n≡m m n))

-- rewrite (v-rm-thm {a = x} {b = prod xs} {x = i} {y = (ix-lookup (idx→off xs iv) zero)} {b≢0 = (a*b≢0⇒b≢0 {a = x} ¬p)})


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

open import lib.Basics
open import lib.NConnected
open import lib.NType2
open import lib.types.FunctionSeq
open import lib.types.Span
open import lib.types.Pointed
open import lib.types.Pushout
open import lib.types.PushoutFlip
open import lib.types.PushoutFmap
open import lib.types.PushoutFlattening
open import lib.types.Unit
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Truncation
open import lib.types.Lift
open import lib.cubical.Cube
open import lib.cubical.Square

-- Suspension is defined as a particular case of pushout

module lib.types.Suspension.Core where

module _ {i} (A : Type i) where

  susp-span : Span
  susp-span = span Unit Unit A (λ _ → tt) (λ _ → tt)

  Susp : Type i
  Susp = Pushout susp-span

  -- [north'] and [south'] explictly ask for [A]

  north' : Susp
  north' = left tt

  south' : Susp
  south' = right tt

module _ {i} {A : Type i} where

  north : Susp A
  north = north' A

  south : Susp A
  south = south' A

  merid : A → north == south
  merid x = glue x

  module SuspElim {j} {P : Susp A → Type j} (n : P north)
    (s : P south) (p : (x : A) → n == s [ P ↓ merid x ]) where

    private
      module P = PushoutElim (λ _ → n) (λ _ → s) p

    abstract
      f : Π (Susp A) P
      f = P.f

      north-β : f north ↦ n
      north-β = P.left-β unit
      {-# REWRITE north-β #-}

      south-β : f south ↦ s
      south-β = P.right-β unit
      {-# REWRITE south-β #-}

      merid-β : ∀ a → apd f (merid a) == p a
      merid-β = P.glue-β

  open SuspElim public using () renaming (f to Susp-elim)

  module SuspRec {j} {C : Type j} (n s : C) (p : A → n == s) where
    private
      module P = PushoutRec {d = susp-span A} (λ _ → n) (λ _ → s) p

    abstract
      f : Susp A → C
      f = P.f

      north-β : f north ↦ n
      north-β = P.left-β unit
      {-# REWRITE north-β #-}

      south-β : f south ↦ s
      south-β = P.right-β unit
      {-# REWRITE south-β #-}

      merid-β : ∀ a → ap f (merid a) == p a
      merid-β = P.glue-β

  open SuspRec public using () renaming (f to Susp-rec)

  module SuspRecType {j} (n s : Type j) (p : A → n ≃ s)
    = PushoutRecType {d = susp-span A} (λ _ → n) (λ _ → s) p

module SuspPathElim
  {i} {j} {A : Type i} {B : Type j}
  (f g : Susp A → B)
  (n : f north == g north)
  (s : f south == g south)
  (m : ∀ a → Square n (ap f (merid a)) (ap g (merid a)) s)
  where

  private
    module M =
      SuspElim
        {P = λ sa → f sa == g sa}
        n
        s
        (λ a → ↓-='-from-square (m a))

  open M public

  merid-square-β : ∀ a → natural-square M.f (merid a) == m a
  merid-square-β a = natural-square-β M.f (merid a) (M.merid-β a)

module SuspDoublePathElim
  {i} {j} {k} {A : Type i} {B : Type j} {C : Type k}
  (f g : Susp A → Susp B → C)
  (n-n : f north north == g north north)
  (n-s : f north south == g north south)
  (s-n : f south north == g south north)
  (s-s : f south south == g south south)
  (n-m : ∀ b → Square n-n (ap (f north) (merid b)) (ap (g north) (merid b)) n-s)
  (s-m : ∀ b → Square s-n (ap (f south) (merid b)) (ap (g south) (merid b)) s-s)
  (m-n : ∀ a → Square n-n (ap (λ sa → f sa north) (merid a)) (ap (λ sa → g sa north) (merid a)) s-n)
  (m-s : ∀ a → Square n-s (ap (λ sa → f sa south) (merid a)) (ap (λ sa → g sa south) (merid a)) s-s)
  (m-m : ∀ a b →
    Cube (m-n a)
         (m-s a)
         (n-m b)
         (natural-square (λ sb → ap (λ sa → f sa sb) (merid a)) (merid b))
         (natural-square (λ sb → ap (λ sa → g sa sb) (merid a)) (merid b))
         (s-m b))
  where

  private
    module N =
      SuspElim
        {P = λ sb → f north sb == g north sb}
        n-n
        n-s
        (λ b → ↓-='-from-square (n-m b))

    n-natural-square : ∀ (b : B) →
      natural-square N.f (merid b) == n-m b
    n-natural-square b = natural-square-β N.f (merid b) (N.merid-β b)

    module S =
      SuspElim
        {P = λ sb → f south sb == g south sb}
        s-n
        s-s
        (λ b → ↓-='-from-square (s-m b))

    s-natural-square : ∀ (b : B) →
      natural-square S.f (merid b) == s-m b
    s-natural-square b = natural-square-β S.f (merid b) (S.merid-β b)

    module M (sb : Susp B) =
      SuspElim {A = A}
        {P = λ sa → f sa sb == g sa sb}
        (N.f sb)
        (S.f sb)
        (λ a → Susp-elim
          {P = λ sb → N.f sb == S.f sb [ (λ sa → f sa sb == g sa sb) ↓ merid a ]}
          (↓-='-from-square (m-n a))
          (↓-='-from-square (m-s a))
          (λ b → ap↓ ↓-='-from-square $
            cube-to-↓-square $
            cube-shift-back (! (n-natural-square b)) $
            cube-shift-front (! (s-natural-square b)) $
            m-m a b)
          sb)

  abstract
    p : ∀ sa sb → f sa sb == g sa sb
    p sa sb = M.f sb sa

    north-north-β : p north north ↦ n-n
    north-north-β = N.north-β
    {-# REWRITE north-north-β #-}

    north-south-β : p north south ↦ n-s
    north-south-β = N.south-β
    {-# REWRITE north-south-β #-}

    south-north-β : p south north ↦ s-n
    south-north-β = S.north-β
    {-# REWRITE south-north-β #-}

    south-south-β : p south south ↦ s-s
    south-south-β = S.south-β
    {-# REWRITE south-south-β #-}

    north-merid-β : ∀ b → apd (p north) (merid b) == ↓-='-from-square (n-m b)
    north-merid-β = N.merid-β

    north-merid-square-β : ∀ b → natural-square (p north) (merid b) == n-m b
    north-merid-square-β b = natural-square-β (p north) (merid b) (north-merid-β b)

    south-merid-β : ∀ b → apd (p south) (merid b) == ↓-='-from-square (s-m b)
    south-merid-β = S.merid-β

    south-merid-square-β : ∀ b → natural-square (p south) (merid b) == s-m b
    south-merid-square-β b = natural-square-β (p south) (merid b) (south-merid-β b)

    merid-north-β : ∀ a → apd (λ sa → p sa north) (merid a) == ↓-='-from-square (m-n a)
    merid-north-β = M.merid-β north

    merid-north-square-β : ∀ a → natural-square (λ sa → p sa north) (merid a) == m-n a
    merid-north-square-β a =
      natural-square-β (λ sa → p sa north) (merid a) (merid-north-β a)

    merid-south-β : ∀ a → apd (λ sa → p sa south) (merid a) == ↓-='-from-square (m-s a)
    merid-south-β = M.merid-β south

    merid-south-square-β : ∀ a → natural-square (λ sa → p sa south) (merid a) == m-s a
    merid-south-square-β a =
      natural-square-β (λ sa → p sa south) (merid a) (merid-south-β a)

susp-⊙span : ∀ {i} → Ptd i → ⊙Span
susp-⊙span X =
  ⊙span ⊙Unit ⊙Unit X (⊙cst {X = X}) (⊙cst {X = X})

⊙Susp : ∀ {i} → Type i → Ptd i
⊙Susp A = ⊙[ Susp A , north ]

σloop : ∀ {i} (X : Ptd i) → de⊙ X → north' (de⊙ X) == north' (de⊙ X)
σloop ⊙[ _ , x₀ ] x = merid x ∙ ! (merid x₀)

σloop-pt : ∀ {i} {X : Ptd i} → σloop X (pt X) == idp
σloop-pt {X = ⊙[ _ , x₀ ]} = !-inv-r (merid x₀)

⊙σloop : ∀ {i} (X : Ptd i) → X ⊙→ ⊙[ north' (de⊙ X) == north' (de⊙ X) , idp ]
⊙σloop X = σloop X , σloop-pt

module _ {i j} where

  module SuspFmap {A : Type i} {B : Type j} (f : A → B) =
    SuspRec north south (merid ∘ f)

  Susp-fmap : {A : Type i} {B : Type j} (f : A → B)
    → (Susp A → Susp B)
  Susp-fmap = SuspFmap.f

  ⊙Susp-fmap : {A : Type i} {B : Type j} (f : A → B)
    → ⊙Susp A ⊙→ ⊙Susp B
  ⊙Susp-fmap f = (Susp-fmap f , idp)

module _ {i} (A : Type i) where

  Susp-fmap-idf : ∀ a → Susp-fmap (idf A) a == a
  Susp-fmap-idf = Susp-elim idp idp $ λ a →
    ↓-='-in' (ap-idf (merid a) ∙ ! (SuspFmap.merid-β (idf A) a))

  ⊙Susp-fmap-idf : ⊙Susp-fmap (idf A) ◃⊙idf =⊙∘ ⊙idf-seq
  ⊙Susp-fmap-idf = =⊙∘-in (⊙λ=' Susp-fmap-idf idp)

transport-Susp : ∀ {i} {A B : Type i} (p : A == B)
  → transport Susp p ∼ Susp-fmap (coe p)
transport-Susp {i} {A} {.A} p@idp sa = ! (Susp-fmap-idf A sa)

⊙transport-⊙Susp : ∀ {i} {A B : Type i} (p : A == B)
  → ⊙transport ⊙Susp p == ⊙Susp-fmap (coe p)
⊙transport-⊙Susp {i} {A} {.A} p@idp = ! (=⊙∘-out (⊙Susp-fmap-idf A))

module _ {i} {A : Type i} where

  Susp-fmap-cst : ∀ {j} {B : Type j} (b : B)
    (a : Susp A) → Susp-fmap (cst b) a == north
  Susp-fmap-cst b = Susp-elim idp (! (merid b)) $ (λ a →
    ↓-app=cst-from-square $ SuspFmap.merid-β (cst b) a ∙v⊡ tr-square _)

  ⊙Susp-fmap-cst : ∀ {j} {Y : Ptd j}
    → ⊙Susp-fmap {A = A} (λ _ → pt Y) == ⊙cst
  ⊙Susp-fmap-cst = ⊙λ=' (Susp-fmap-cst _) idp

Susp-fmap-∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
  (σ : Susp A) → Susp-fmap (g ∘ f) σ == Susp-fmap g (Susp-fmap f σ)
Susp-fmap-∘ g f = Susp-elim
  idp
  idp
  (λ a → ↓-='-in' $
    ap-∘ (Susp-fmap g) (Susp-fmap f) (merid a)
    ∙ ap (ap (Susp-fmap g)) (SuspFmap.merid-β f a)
    ∙ SuspFmap.merid-β g (f a)
    ∙ ! (SuspFmap.merid-β (g ∘ f) a))

⊙Susp-fmap-∘ : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  (g : B → C) (f : A → B)
  → ⊙Susp-fmap (g ∘ f) == ⊙Susp-fmap g ⊙∘ ⊙Susp-fmap f
⊙Susp-fmap-∘ g f = ⊙λ=' (Susp-fmap-∘ g f) idp

⊙Susp-fmap-seq : ∀ {i} {A B : Type i} → (A –→ B) → ⊙Susp A ⊙–→ ⊙Susp B
⊙Susp-fmap-seq idf-seq = ⊙idf-seq
⊙Susp-fmap-seq (f ◃∘ fs) = ⊙Susp-fmap f ◃⊙∘ ⊙Susp-fmap-seq fs

abstract
  ⊙Susp-fmap-seq-∘ : ∀ {i} {A B : Type i} (fs : A –→ B)
    → ⊙Susp-fmap (compose fs) ◃⊙idf =⊙∘ ⊙Susp-fmap-seq fs
  ⊙Susp-fmap-seq-∘ idf-seq = ⊙Susp-fmap-idf _
  ⊙Susp-fmap-seq-∘ (f ◃∘ fs) = =⊙∘-in $
    ⊙Susp-fmap (f ∘ compose fs)
      =⟨ ⊙Susp-fmap-∘ f (compose fs) ⟩
    ⊙Susp-fmap f ⊙∘ ⊙Susp-fmap (compose fs)
      =⟨ ap (⊙Susp-fmap f ⊙∘_) (=⊙∘-out (⊙Susp-fmap-seq-∘ fs)) ⟩
    ⊙Susp-fmap f ⊙∘ ⊙compose (⊙Susp-fmap-seq fs) =∎

  ⊙Susp-fmap-seq-=⊙∘ : ∀ {i} {A B : Type i} {fs gs : A –→ B}
    → fs =∘ gs
    → ⊙Susp-fmap-seq fs =⊙∘ ⊙Susp-fmap-seq gs
  ⊙Susp-fmap-seq-=⊙∘ {fs = fs} {gs = gs} p =
    ⊙Susp-fmap-seq fs
      =⊙∘⟨ !⊙∘ (⊙Susp-fmap-seq-∘ fs) ⟩
    ⊙Susp-fmap (compose fs) ◃⊙idf
      =⊙∘₁⟨ ap ⊙Susp-fmap (=∘-out p) ⟩
    ⊙Susp-fmap (compose gs) ◃⊙idf
      =⊙∘⟨ ⊙Susp-fmap-seq-∘ gs ⟩
    ⊙Susp-fmap-seq gs ∎⊙∘

{- Extract the 'glue component' of a pushout -}
module _ {i j k} {s : Span {i} {j} {k}} where

  module ExtractGlue = PushoutRec {d = s} {D = Susp (Span.C s)}
    (λ _ → north) (λ _ → south) merid

  extract-glue = ExtractGlue.f

  module _ {x₀ : Span.A s} where

    ⊙extract-glue : ⊙[ Pushout s , left x₀ ] ⊙→ ⊙[ Susp (Span.C s) , north ]
    ⊙extract-glue = extract-glue , idp

module _ {i j} {A : Type i} {B : Type j} (eq : A ≃ B) where

  Susp-emap : Susp A ≃ Susp B
  Susp-emap =
    equiv
      (Susp-fmap (–> eq))
      (Susp-fmap (<– eq))
      (λ sb →
        Susp-fmap (–> eq) (Susp-fmap (<– eq) sb)
          =⟨ ! (Susp-fmap-∘ (–> eq) (<– eq) sb) ⟩
        Susp-fmap ((–> eq) ∘ (<– eq)) sb
          =⟨ ap (λ f → Susp-fmap f sb) (λ= (<–-inv-r eq)) ⟩
        Susp-fmap (idf B) sb
          =⟨ Susp-fmap-idf _ sb ⟩
        sb =∎)
      (λ sa →
        Susp-fmap (<– eq) (Susp-fmap (–> eq) sa)
          =⟨ ! (Susp-fmap-∘ (<– eq) (–> eq) sa) ⟩
        Susp-fmap ((<– eq) ∘ (–> eq)) sa
          =⟨ ap (λ f → Susp-fmap f sa) (λ= (<–-inv-l eq)) ⟩
        Susp-fmap (idf A) sa
          =⟨ Susp-fmap-idf _ sa ⟩
        sa =∎)

  private
    -- This is to make sure that we did not screw up [Susp-emap].
    test₀ : fst Susp-emap == Susp-fmap (fst eq)
    test₀ = idp

module _ {i j} {A : Type i} {B : Type j} where

  ⊙Susp-emap : A ≃ B → ⊙Susp A ⊙≃ ⊙Susp B
  ⊙Susp-emap eq = ≃-to-⊙≃ (Susp-emap eq) idp

{- Interaction with [Lift] -}
module _ {i j} (A : Type i) where

  Susp-Lift-econv : Susp (Lift {j = j} A) ≃ Lift {j = j} (Susp A)
  Susp-Lift-econv = lift-equiv ∘e Susp-emap lower-equiv

  Susp-Lift-conv : Susp (Lift {j = j} A) == Lift {j = j} (Susp A)
  Susp-Lift-conv = ua Susp-Lift-econv

module _ {i j} (A : Type i) where

  ⊙Susp-Lift-econv : ⊙Susp (Lift {j = j} A) ⊙≃ ⊙Lift {j = j} (⊙Susp A)
  ⊙Susp-Lift-econv = ⊙lift-equiv {j = j} ⊙∘e ⊙Susp-emap {A = Lift {j = j} A} {B = A} lower-equiv

  ⊙Susp-Lift-conv : ⊙Susp (Lift {j = j} A) == ⊙Lift {j = j} (⊙Susp A)
  ⊙Susp-Lift-conv = ⊙ua ⊙Susp-Lift-econv

{- Suspension of an n-connected space is n+1-connected -}
abstract
  Susp-conn : ∀ {i} {A : Type i} {n : ℕ₋₂}
    → is-connected n A → is-connected (S n) (Susp A)
  Susp-conn {A = A} {n = n} cA = has-level-in
    ([ north ] ,
     Trunc-elim
       (Susp-elim
         idp
         (Trunc-rec (λ a → ap [_] (merid a))
                    (contr-center cA))
         (λ x → Trunc-elim
            {P = λ y → idp ==
              Trunc-rec (λ a → ap [_] (merid a)) y
              [ (λ z → [ north ] == [ z ]) ↓ (merid x) ]}
            {{λ _ → ↓-preserves-level ⟨⟩}}
            (λ x' → ↓-cst=app-in (∙'-unit-l _ ∙ mers-eq n x x'))
            (contr-center cA))))
    where
    instance _ = cA

    mers-eq : ∀ {i} {A : Type i} (n : ℕ₋₂)
      {{_ : is-connected n A}} → (x x' : A)
      → ap ([_] {n = S n}) (merid x)
        == Trunc-rec {{has-level-apply (Trunc-level {n = S n}) _ _}} (λ a → ap [_] (merid a)) [ x' ]
    mers-eq ⟨-2⟩ x x' = contr-has-all-paths _ _
    mers-eq {A = A} (S n) x x' =
      conn-extend (pointed-conn-out A x)
        (λ y → ((ap [_] (merid x) == ap [_] (merid y)) ,
                has-level-apply (has-level-apply (Trunc-level {n = S (S n)}) _ _) _ _))
        (λ _ → idp) x'


module Issue599 where

data Bool : Set where
  true false : Bool

-- standard lambda here
foo : Bool → Bool
foo = ?

-- pattern matching lambda here
bar : Bool → Bool
bar = ?


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

open import HoTT
open import homotopy.LoopSpaceCircle

-- This file is temporarily put in the cw/ directory for
-- development, but it actually belongs to somewhere else.

module homotopy.SphereEndomorphism where

  ⊙SphereS-endo-out : ∀ n
    → Trunc 0 (⊙Sphere (S n) ⊙→ ⊙Sphere (S n))
    → Trunc 0 ( Sphere (S n)  →  Sphere (S n))
  ⊙SphereS-endo-out n = Trunc-rec Trunc-level ([_] ∘ fst)

  -- For [S¹], the pointedness is free because of the commutativity of its loop space.

  -- favonia: maybe one can simplify the proofs through
  --          an intermediate type [Σ S¹ (λ x → x == x)]?

  private
    ⊙S¹-endo-in'' : (base* : S¹) (loop* : base* == base*) → (⊙S¹ ⊙→ ⊙S¹)
    ⊙S¹-endo-in'' = S¹-elim
      (λ loop* → S¹-rec base loop* , idp)
      (↓-app→cst-in λ r → ap (λ loop* → (S¹-rec base loop* , idp)) (lemma₀ r)) where
      abstract
        lemma₀ : ∀ {loop₁ loop₂}
          → loop₁ == loop₂ [ (λ x → x == x) ↓ loop ]
          → loop₁ == loop₂
        lemma₀ {loop₁} {loop₂} p = anti-whisker-right loop $
          loop₁ ∙ loop
            =⟨ ↓-idf=idf-out' p ⟩
          loop ∙' loop₂
            =⟨ ∙'=∙ loop loop₂ ⟩
          loop ∙ loop₂
            =⟨ ΩS¹-is-abelian loop loop₂ ⟩
          loop₂ ∙ loop
            =∎

    ⊙S¹-endo-in' : (S¹ → S¹) → (⊙S¹ ⊙→ ⊙S¹)
    ⊙S¹-endo-in' f = ⊙S¹-endo-in'' (f base) (ap f loop)

  ⊙S¹-endo-in : Trunc 0 (S¹ → S¹) → Trunc 0 (⊙S¹ ⊙→ ⊙S¹)
  ⊙S¹-endo-in = Trunc-fmap ⊙S¹-endo-in'

  abstract
    ⊙S¹-endo-in-η : ∀ f → ⊙S¹-endo-in (⊙SphereS-endo-out 0 f) == f
    ⊙S¹-endo-in-η = Trunc-elim (λ _ → =-preserves-set Trunc-level)
      λ{(f , pt) → ap [_] $
        ⊙S¹-endo-in''-shifted pt (ap f loop) ∙ ⊙λ= (S¹-rec-η f) idp}
      where
      -- free one end to apply identification elimination
      ⊙S¹-endo-in''-shifted : {base* : S¹}
        (shift : base* == base) (loop* : base* == base*)
        → ⊙S¹-endo-in'' base* loop* == (S¹-rec base* loop* , shift)
      ⊙S¹-endo-in''-shifted idp _ = idp

    ⊙S¹-endo-out-β : ∀ f → ⊙SphereS-endo-out 0 (⊙S¹-endo-in f) == f
    ⊙S¹-endo-out-β = Trunc-elim (λ _ → =-preserves-level Trunc-level)
      λ f → ! (ap (λ f → [ fst (⊙S¹-endo-in' f) ]) (λ= $ S¹-rec-η f))
          ∙ ⊙S¹-endo-out'-β (f base) (ap f loop)
          ∙ ap [_] (λ= $ S¹-rec-η f)
      where
        -- free [base*] to apply circle elimination
        ⊙S¹-endo-out'-β : (base* : S¹) (loop* : base* == base*)
          →  [ fst (⊙S¹-endo-in' (S¹-rec base* loop*)) ]
          == [ S¹-rec base* loop* ] :> Trunc 0 (S¹ → S¹)
        ⊙S¹-endo-out'-β = S¹-elim
          (λ loop* → ap (λ loop* → [ S¹-rec base loop* ]) (S¹Rec.loop-β base loop*))
          (prop-has-all-paths-↓ $ Π-is-prop λ loop* → Trunc-level {n = 0} _ _)

  ⊙S¹-endo-out-is-equiv : is-equiv (⊙SphereS-endo-out 0)
  ⊙S¹-endo-out-is-equiv = is-eq _ ⊙S¹-endo-in ⊙S¹-endo-out-β ⊙S¹-endo-in-η

  -- For [Sphere (S (S n))], the pointedness is free because of its connectivity.

  private
    SphereSS-conn : ∀ n → is-connected 1 (Sphere (S (S n)))
    SphereSS-conn n = connected-≤T (≤T-+2+-l 1 (-2≤T ⟨ n ⟩₋₂)) (Sphere-conn (S (S n)))

    SphereSS-conn-path : ∀ n (x y : Sphere (S (S n))) → is-connected 0 (x == y)
    SphereSS-conn-path n x y = path-conn (SphereSS-conn n)

    SphereSS-has-all-trunc-paths : ∀ n (x y : Sphere (S (S n))) → Trunc 0 (x == y)
    SphereSS-has-all-trunc-paths n x y = –> (Trunc=-equiv [ x ] [ y ])
      (contr-has-all-paths (SphereSS-conn n) [ x ] [ y ])

  ⊙SphereSS-endo-in : ∀ n
    → Trunc 0 ( Sphere (S (S n))  →  Sphere (S (S n)))
    → Trunc 0 (⊙Sphere (S (S n)) ⊙→ ⊙Sphere (S (S n)))
  ⊙SphereSS-endo-in n = Trunc-rec Trunc-level λ f →
    Trunc-rec Trunc-level (λ pt → [ f , pt ])
      (SphereSS-has-all-trunc-paths n (f north) north)

  abstract
    ⊙SphereSS-endo-in-η : ∀ n f → ⊙SphereSS-endo-in n (⊙SphereS-endo-out (S n) f) == f
    ⊙SphereSS-endo-in-η n = Trunc-elim (λ _ → =-preserves-set Trunc-level)
      λ{(f , pt) → ap (Trunc-rec Trunc-level (λ pt → [ f , pt ]))
        (contr-has-all-paths (SphereSS-conn-path n (f north) north)
          (SphereSS-has-all-trunc-paths n (f north) north) [ pt ])}

    ⊙SphereSS-endo-out-β : ∀ n f → ⊙SphereS-endo-out (S n) (⊙SphereSS-endo-in n f) == f
    ⊙SphereSS-endo-out-β n = Trunc-elim (λ _ → =-preserves-set Trunc-level)
      λ f → Trunc-elim
        {P = λ pt → ⊙SphereS-endo-out (S n) (Trunc-rec Trunc-level (λ pt → [ f , pt ]) pt) == [ f ]}
        (λ _ → =-preserves-set Trunc-level)
        (λ pt → idp) (SphereSS-has-all-trunc-paths n (f north) north)

  ⊙SphereSS-endo-out-is-equiv : ∀ n → is-equiv (⊙SphereS-endo-out (S n))
  ⊙SphereSS-endo-out-is-equiv n = is-eq
    (⊙SphereS-endo-out (S n)) (⊙SphereSS-endo-in n)
    (⊙SphereSS-endo-out-β n) (⊙SphereSS-endo-in-η n)

  -- the unified interface

  ⊙SphereS-endo-out-is-equiv : ∀ n → is-equiv (⊙SphereS-endo-out n)
  ⊙SphereS-endo-out-is-equiv 0 = ⊙S¹-endo-out-is-equiv
  ⊙SphereS-endo-out-is-equiv (S n) = ⊙SphereSS-endo-out-is-equiv n

  ⊙SphereS-endo-in : ∀ n
    → Trunc 0 ( Sphere (S n)  →  Sphere (S n))
    → Trunc 0 (⊙Sphere (S n) ⊙→ ⊙Sphere (S n))
  ⊙SphereS-endo-in n = is-equiv.g (⊙SphereS-endo-out-is-equiv n)


------------------------------------------------------------------------
-- Very stable booleans
------------------------------------------------------------------------

{-# OPTIONS --cubical --safe #-}

-- The module is parametrised by a notion of equality. The higher
-- constructor of the HIT defining the very stable booleans uses path
-- equality, but the supplied notion of equality is used for other
-- things.

import Equality.Path as P

module Bool.Very-stable
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

import Equality.Path.Univalence as PU
open import Prelude as Bool hiding (true; false)

open import Bijection equality-with-J using (_↔_)
import Bijection P.equality-with-J as PB
open import Equality.Decision-procedures equality-with-J
open import Equality.Path.Isomorphisms eq
open import Equality.Path.Isomorphisms.Univalence eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Erased.Cubical eq as Erased
import Erased.Cubical P.equality-with-paths as PE
open import Function-universe equality-with-J hiding (_∘_)
open import Injection equality-with-J using (Injective)

private
  variable
    a p          : Level
    A            : Type a
    P            : A → Type p
    b f r r-[] t : A

------------------------------------------------------------------------
-- Very stable booleans

-- Very stable booleans.
--
-- This type uses a construction due to Thierry Coquand and Fabian
-- Ruch. I think this construction is a variant of a construction due
-- to Rijke, Shulman and Spitters (see "Modalities in Homotopy Type
-- Theory").

data B̃ool : Type where
  true false : B̃ool
  stable     : Erased B̃ool → B̃ool
  stable-[]ᴾ : (b : B̃ool) → stable [ b ] P.≡ b

-- The constructor stable is a left inverse of [_].

stable-[] : (b : B̃ool) → stable [ b ] ≡ b
stable-[] = _↔_.from ≡↔≡ ∘ stable-[]ᴾ

-- B̃ool is very stable.

Very-stable-B̃ool : Very-stable B̃ool
Very-stable-B̃ool = Stable→Left-inverse→Very-stable stable stable-[]

------------------------------------------------------------------------
-- Eliminators

-- A dependent eliminator, expressed using paths.

elimᴾ :
  (P : B̃ool → Type p) →
  P true →
  P false →
  (r : ∀ b → Erased (P (erased b)) → P (stable b)) →
  (∀ b (p : P b) →
   P.[ (λ i → P (stable-[]ᴾ b i)) ] r [ b ] [ p ] ≡ p) →
  ∀ b → P b
elimᴾ P t f r r-[] = λ where
  true             → t
  false            → f
  (stable b)       → r b [ elimᴾ P t f r r-[] (erased b) ]
  (stable-[]ᴾ b i) → r-[] b (elimᴾ P t f r r-[] b) i

-- A non-dependent eliminator, expressed using paths.

recᴾ :
  A → A →
  (r : Erased B̃ool → Erased A → A) →
  (∀ b p → r [ b ] [ p ] P.≡ p) →
  B̃ool → A
recᴾ = elimᴾ _

-- A dependent eliminator, expressed using equality.

elim :
  (P : B̃ool → Type p) →
  P true →
  P false →
  (r : ∀ b → Erased (P (erased b)) → P (stable b)) →
  (∀ b (p : P b) → subst P (stable-[] b) (r [ b ] [ p ]) ≡ p) →
  ∀ b → P b
elim P t f r r-[] = elimᴾ P t f r (λ b p → subst≡→[]≡ (r-[] b p))

-- A "computation" rule.

elim-stable-[] :
  dcong (elim P t f r r-[]) (stable-[] b) ≡
  r-[] b (elim P t f r r-[] b)
elim-stable-[] = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator, expressed using equality.

rec :
  A → A →
  (r : Erased B̃ool → Erased A → A) →
  (∀ b p → r [ b ] [ p ] ≡ p) →
  B̃ool → A
rec t f r r-[] = recᴾ t f r (λ b p → _↔_.to ≡↔≡ (r-[] b p))

-- A "computation" rule.

rec-stable-[] :
  cong (rec t f r r-[]) (stable-[] b) ≡
  r-[] b (rec t f r r-[] b)
rec-stable-[] = cong-≡↔≡ (refl _)

-- A dependent eliminator that can be used when eliminating into very
-- stable type families.

elim-Very-stable :
  (P : B̃ool → Type p) →
  P true →
  P false →
  (∀ b → Very-stable (P b)) →
  ∀ b → P b
elim-Very-stable P t f s =
  elim P t f
    (λ b →
       Erased (P (erased b))  ↝⟨ Erased.map (subst P (

           erased b                ≡⟨ sym $ stable-[] (erased b) ⟩∎
           stable b                ∎)) ⟩

       Erased (P (stable b))  ↝⟨ Very-stable→Stable 0 (s (stable b)) ⟩□

       P (stable b)           □)
    (λ b p →
       Very-stable→Stable 1 (Very-stable→Very-stable-≡ 0 (s b)) _ _
         [ subst P (stable-[] b)
             (_≃_.from Eq.⟨ _ , s (stable [ b ]) ⟩
                [ subst P (sym $ stable-[] b) p ])                ≡⟨ cong (subst P (stable-[] b)) $ sym $
                                                                     _≃_.left-inverse-unique Eq.⟨ _ , s (stable [ b ]) ⟩ erased refl _ ⟩
           subst P (stable-[] b)
             (erased [ subst P (sym $ stable-[] b) p ])           ≡⟨⟩

           subst P (stable-[] b) (subst P (sym $ stable-[] b) p)  ≡⟨ subst-subst-sym _ _ _ ⟩∎

           p                                                      ∎
         ])

-- A non-dependent eliminator that can be used when eliminating into
-- very stable type families.

rec-Very-stable : A → A → Very-stable A → B̃ool → A
rec-Very-stable t f s = elim-Very-stable _ t f (λ _ → s)

------------------------------------------------------------------------
-- Some properties

private
 module Dummy where

  -- A function mapping very stable booleans to types: true is mapped
  -- to the unit type and false to the empty type.

  private

    T̃′ : B̃ool → Σ Type Very-stable
    T̃′ = rec-Very-stable
      (⊤ , Very-stable-⊤)
      (⊥ , Very-stable-⊥)
      (Very-stable-∃-Very-stable ext univ)

  T̃ : B̃ool → Type
  T̃ = proj₁ ∘ T̃′

  -- Some computation rules that hold by definition.

  _ : T̃ true ≡ ⊤
  _ = refl _

  _ : T̃ false ≡ ⊥
  _ = refl _

  -- The output of T̃ is very stable.

  Very-stable-T̃ : ∀ b → Very-stable (T̃ b)
  Very-stable-T̃ = proj₂ ∘ T̃′

  -- The values true and false are not equal.

  true≢false : true ≢ false
  true≢false =
    true ≡ false      ↝⟨ cong T̃ ⟩
    T̃ true ≡ T̃ false  ↔⟨⟩
    ⊤ ≡ ⊥             ↝⟨ (λ eq → ≡⇒↝ _ eq _) ⟩□
    ⊥                 □

module Alternative-T̃ where

  -- A direct implementation of T̃.

  private

    T̃′ : B̃ool → Σ Type PE.Very-stable

  T̃ : B̃ool → Type
  T̃ b = proj₁ (T̃′ b)

  Very-stable-T̃ : ∀ b → PE.Very-stable (T̃ b)
  Very-stable-T̃ b = proj₂ (T̃′ b)

  T̃′ true             = ⊤ , PE.Very-stable-⊤
  T̃′ false            = ⊥ , PE.Very-stable-⊥
  T̃′ (stable [ b ])   = PE.Erased (T̃ b) , PE.Very-stable-Erased
  T̃′ (stable-[]ᴾ b i) = lemma₁ i , lemma₂ i
    where
    lemma₁ : PE.Erased (T̃ b) P.≡ T̃ b
    lemma₁ = PU.≃⇒≡ (PE.Very-stable→Stable 0 (Very-stable-T̃ b))

    lemma₂ :
      P.[ (λ i → PE.Very-stable (lemma₁ i)) ]
        PE.Very-stable-Erased ≡ Very-stable-T̃ b
    lemma₂ =
      P.heterogeneous-irrelevance₀
        (PE.Very-stable-propositional P.ext)

  -- Some computation rules that hold by definition.

  _ : T̃ true ≡ ⊤
  _ = refl _

  _ : T̃ false ≡ ⊥
  _ = refl _

  _ : T̃ (stable [ b ]) ≡ PE.Erased (T̃ b)
  _ = refl _

open Dummy public

-- A function from booleans to very stable booleans.

from-Bool : Bool → B̃ool
from-Bool = if_then true else false

-- The function from-Bool is injective.
--
-- This lemma was suggested by Mike Shulman.

from-Bool-injective : Injective from-Bool
from-Bool-injective {x = Bool.true}  {y = Bool.true}  = λ _ → refl _
from-Bool-injective {x = Bool.true}  {y = Bool.false} = ⊥-elim ∘ true≢false
from-Bool-injective {x = Bool.false} {y = Bool.true}  = ⊥-elim ∘ true≢false ∘ sym
from-Bool-injective {x = Bool.false} {y = Bool.false} = λ _ → refl _

-- B̃ool is equivalent to Erased Bool.
--
-- This lemma was suggested by Mike Shulman.

B̃ool≃Erased-Bool : B̃ool ≃ Erased Bool
B̃ool≃Erased-Bool = Eq.↔⇒≃ (record
  { surjection = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = λ b →
        Very-stable→Stable 0
          (Very-stable→Very-stable-≡ 0 Very-stable-Erased _ _)
          [ to (from b)                           ≡⟨⟩
            to (stable [ from-Bool (erased b) ])  ≡⟨ cong to (stable-[] _) ⟩
            to (from-Bool (erased b))             ≡⟨ lemma (erased b) ⟩
            [ erased b ]                          ≡⟨⟩
            b                                     ∎
          ]
    }
  ; left-inverse-of = elim-Very-stable
      _
      (stable-[] true)
      (stable-[] false)
      (λ _ → Very-stable→Very-stable-≡ 0 Very-stable-B̃ool _ _)
  })
  where
  to = rec-Very-stable [ Bool.true ] [ Bool.false ] Very-stable-Erased

  from = stable ∘ Erased.map from-Bool

  lemma : ∀ b → to (from-Bool b) ≡ [ b ]
  lemma Bool.true  = refl _
  lemma Bool.false = refl _

------------------------------------------------------------------------
-- An example

private

  -- At the time of writing it is unclear if there is a reasonable way
  -- to compile very stable booleans. The constructors true and false
  -- are distinct, and it is reasonable to think that a compiler will
  -- compile them in different ways. Now consider the following two
  -- very stable booleans:

  b₁ : B̃ool
  b₁ = stable [ true ]

  b₂ : B̃ool
  b₂ = stable [ false ]

  -- The first one is equal to true, and the second one is equal to
  -- false:

  _ : b₁ ≡ true
  _ = stable-[] true

  _ : b₂ ≡ false
  _ = stable-[] false

  -- However, unlike the constructors true and false, b₁ and b₂ should
  -- be compiled in the same way, because the argument to [_] is
  -- erased.

  -- One question, raised by Andrea Vezzosi, is whether it is possible
  -- to write a program that gives /observably/ different results
  -- (after erasure) for true and false. If this is the case, then the
  -- erasure mechanism is not well-behaved.


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

-- Drop-in replacement for the module [Base].
module BaseOver where

-- We hide [apd] and [Σ-eq] because their type is not correct, we want to use
-- dependent paths instead
open import Base public hiding (apd; Σ-eq)

-- Notion of path over a path
path-over : ∀ {i j} {A : Set i} (B : A → Set j)
  {x y : A} (p : x == y) (u : B x) (v : B y) → Set j
path-over B refl u v = (u == v)

syntax path-over B p u v =
  u == v [ B ↓ p ]

-- New apd
apd : ∀ {i j} {A : Set i} {B : A → Set j} (f : (a : A) → B a) {x y : A}
  → (p : x == y) → f x == f y [ B ↓ p ]
apd f refl = refl

-- Σ-types are used to simulate telescopes and to be able to only use the
-- notion of path over a single path

-- Intro for paths in a Σ
Σ-eq : ∀ {i j} {A : Set i} {B : A → Set j} {x y : A} (p : x == y)
  {u : B x} {v : B y} (q : u == v [ B ↓ p ])
  → (x , u) == (y , v)
Σ-eq refl refl = refl

uncurryi : ∀ {i j k} {A : Set i} {B : A → Set j} {C : ∀ x → B x → Set k}
  → (∀ {x} y → C x y) → (∀ s → C (π₁ s) (π₂ s))
uncurryi f (x , y) = f y

apdd : ∀ {i j k} {A : Set i} {B : A → Set j} {C : (a : A) → B a → Set k}
  (g : {a : A} → Π (B a) (C a)) {x y : A} (p : x == y)
  {u : B x} {v : B y} (q : u == v [ B ↓ p ])
  → g u == g v [ uncurry C ↓ Σ-eq p q ]
apdd g p q = apd (uncurryi g) (Σ-eq p q)

-- Dependent paths in a constant fibration
module _ {i j} {A : Set i} {B : Set j} where

  ↓-cst-in : {x y : A} (p : x == y) {u v : B}
    → u == v
    → u == v [ (λ _ → B) ↓ p ]
  ↓-cst-in refl q = q

  ↓-cst-out : {x y : A} {p : x == y} {u v : B}
    → u == v [ (λ _ → B) ↓ p ]
    → u == v
  ↓-cst-out {p = refl} q = q

  ↓-cst-β : {x y : A} (p : x == y) {u v : B} (q : u == v)
    → (↓-cst-out (↓-cst-in p q) == q)
  ↓-cst-β refl q = refl

-- -- ap can be defined via apd, not sure whether it’s a good idea or not
-- ap : ∀ {i j} {A : Set i} {B : Set j} (f : A → B) {x y : A} (p : x == y)
--   → f x == f y
-- ap f p = ↓-cst-out (apd f p)

-- Dependent paths in a Π-type
module _ {i j k} {A : Set i} {B : A → Set j} {C : (a : A) → B a → Set k} where

  ↓-Π-in : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t' [ uncurry C ↓ Σ-eq p q ])
    → (u == u' [ (λ x → Π (B x) (C x)) ↓ p ])
  ↓-Π-in {p = refl} f = funext (λ x → f (refl {a = x}))

  ↓-Π-out : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → (u == u' [ (λ x → Π (B x) (C x)) ↓ p ])
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t' [ uncurry C ↓ Σ-eq p q ])
  ↓-Π-out {p = refl} q refl = happly q _

  ↓-Π-β : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → (f : {t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
            → u t == u' t' [ uncurry C ↓ Σ-eq p q ])
    → {t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
    → ↓-Π-out (↓-Π-in f) q == f q
  ↓-Π-β {p = refl} f refl = happly (happly-funext (λ x → f (refl {a = x}))) _

-- Dependent paths in a Π-type where the codomain is not dependent on anything
module _ {i j k} {A : Set i} {B : A → Set j} {C : Set k} {x x' : A} {p : x == x'}
  {u : B x → C} {u' : B x' → C} where

  ↓-app→cst-in :
    ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
      → u t == u' t')
    → (u == u' [ (λ x → B x → C) ↓ p ])
  ↓-app→cst-in f = ↓-Π-in (λ q → ↓-cst-in (Σ-eq p q) (f q))

  ↓-app→cst-out :
    (u == u' [ (λ x → B x → C) ↓ p ])
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t')
  ↓-app→cst-out r q = ↓-cst-out (↓-Π-out r q)

  ↓-app→cst-β :
    (f : ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
           → u t == u' t'))
    → {t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
    → ↓-app→cst-out (↓-app→cst-in f) q == f q
  ↓-app→cst-β f q =
    ↓-app→cst-out (↓-app→cst-in f) q
             ≡⟨ refl ⟩
    ↓-cst-out (↓-Π-out (↓-Π-in (λ qq → ↓-cst-in (Σ-eq p qq) (f qq))) q)
             ≡⟨ ↓-Π-β (λ qq → ↓-cst-in (Σ-eq p qq) (f qq)) q |in-ctx ↓-cst-out ⟩
    ↓-cst-out (↓-cst-in (Σ-eq p q) (f q))
             ≡⟨ ↓-cst-β (Σ-eq p q) (f q) ⟩
    f q ∎

-- Dependent paths in a Π-type where the domain is constant
module _ {i j k} {A : Set i} {B : Set j} {C : A → B → Set k}
  {x x' : A} {p : x == x'}
  {u : (b : B) → C x b} {u' : (b : B) → C x' b} where

  postulate
    ↓-cst→app-in :
      ({t t' : B} (q : t == t')
        → u t == u' t' [ uncurry C ↓ Σ-eq p (↓-cst-in p q) ])
      → (u == u' [ (λ x → (b : B) → C x b) ↓ p ])
--  ↓-cst→app-in f = ↓-Π-in (λ q → {!f (↓-cst-out q)!})

  postulate
    ↓-cst→app-out :
      (u == u' [ (λ x → (b : B) → C x b) ↓ p ])
      → ({t t' : B} (q : t == t')
        → u t == u' t' [ uncurry C ↓ Σ-eq p (↓-cst-in p q) ])

split-ap2 : ∀ {i j k} {A : Set i} {B : A → Set j} {C : Set k} (f : Σ A B → C)
  {x y : A} (p : x == y)
  {u : B x} {v : B y} (q : u == v [ B ↓ p ])
  → ap f (Σ-eq p q) == ↓-app→cst-out (apd (curry f) p) q
split-ap2 f refl refl = refl

↓-app='cst-in : ∀ {i j} {A : Set i} {B : Set j} {f : A → B} {b : B}
  {x y : A} {p : x == y} {u : f x == b} {v : f y == b}
  → u == (ap f p ∘' v)
  → (u == v [ (λ x → f x == b) ↓ p ])
↓-app='cst-in {p = refl} q = q ∘ refl-left-unit _

↓-app='cst-out : ∀ {i j} {A : Set i} {B : Set j} {f : A → B} {b : B}
  {x y : A} {p : x == y} {u : f x == b} {v : f y == b}
  → (u == v [ (λ x → f x == b) ↓ p ])
  → u == (ap f p ∘' v)
↓-app='cst-out {p = refl} refl = ! (refl-left-unit _)

↓-cst='app-in : ∀ {i j} {A : Set i} {B : Set j} {f : A → B} {b : B}
  {x y : A} {p : x == y} {u : b == f x} {v : b == f y}
  → (u ∘' ap f p) == v
  → (u == v [ (λ x → b == f x) ↓ p ])
↓-cst='app-in {p = refl} refl = refl

↓-cst='app-out : ∀ {i j} {A : Set i} {B : Set j} {f : A → B} {b : B}
  {x y : A} {p : x == y} {u : b == f x} {v : b == f y}
  → (u == v [ (λ x → b == f x) ↓ p ])
  → (u ∘' ap f p) == v
↓-cst='app-out {p = refl} refl = refl

↓-='-in : ∀ {i j} {A : Set i} {B : Set j} {f g : A → B}
  {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
  → (u ∘ ap g p) == (ap f p ∘' v)
  → (u == v [ (λ x → f x == g x) ↓ p ])
↓-='-in {p = refl} q = ! (refl-right-unit _) ∘ (q ∘ refl-left-unit _)

-- Dependent vs nondependent whiskering
-- This definitional behaviour make [↓-=-in] slightly more complicated to prove
-- but [↓-=-in] is often used in the case where [u] and [v] are [refl]
_▹_ : ∀ {i j} {A : Set i} {B : A → Set j} {x y : A} {u : B x}
  {v w : B y} {p : x == y}
  → (u == v [ B ↓ p ]) → v == w
     → (u == w [ B ↓ p ])
_▹_ {p = refl} q refl = q

refl▹ : ∀ {i j} {A : Set i} {B : A → Set j} {x : A}
  {v w : B x} (q : v == w)
  → _▹_ {B = B} {p = refl} refl q == q
refl▹ refl = refl

_◃_ : ∀ {i j} {A : Set i} {B : A → Set j} {x y : A} {u v : B x}
  {w : B y} {p : x == y}
  → (u == v → (v == w [ B ↓ p ])
     → (u == w [ B ↓ p ]))
_◃_ {p = refl} refl q = q

◃refl : ∀ {i j} {A : Set i} {B : A → Set j} {x : A}
  {v w : B x} (q : v == w)
  → _◃_ {B = B} {p = refl} q refl == q
◃refl refl = refl

↓-=-in : ∀ {i j} {A : Set i} {B : A → Set j} {f g : Π A B}
  {x y : A} {p : x == y} {u : g x == f x} {v : g y == f y}
  → (u ◃ apd f p) == (apd g p ▹ v)
  → (u == v [ (λ x → g x == f x) ↓ p ])
↓-=-in {B = B} {p = refl} {u} {v} q =
  ! (◃refl {B = B} u) ∘ (q ∘ refl▹ {B = B} v)

postulate
 ↓-=-out : ∀ {i j} {A : Set i} {B : A → Set j} {f g : Π A B}
  {x y : A} {p : x == y} {u : g x == f x} {v : g y == f y}
  → (u == v [ (λ x → g x == f x) ↓ p ])
  → (u ◃ apd f p) == (apd g p ▹ v)
--↓-=-out {B = B} {p = refl} refl = {!!}

{- Not used yet

apdd-cst : ∀ {i j k} {A : Set i} {B : Set j} {C : A → B → Set k}
  (g : (a : A) → Π B (C a)) {x y : A} (p : x ≡ y)
  {u v : B} (q : u ≡ v) {r : u ≡[ (λ _ → B) ↓ p ] v} (α : ↓-cst-in p q ≡ r)
  → apdd (λ {a} b → g a b) p r ≡ apd (uncurry g) (Σ-eq p r)
apdd-cst g refl refl refl = refl
-}
-- This one seems a bit weird
↓-apd-out : ∀ {i j k} {A : Set i} {B : A → Set j} (C : (a : A) → B a → Set k)
  (f : Π A B) {x y : A} (p : x == y)
  {u : C x (f x)} {v : C y (f y)}
  → u == v [ uncurry C ↓ Σ-eq p (apd f p) ]
  → u == v [ (λ z → C z (f z)) ↓ p ]
↓-apd-out C f refl refl = refl
{-
-- Dependent paths over [ap f p]
module _ {i j k} {A : Set i} {B : Set j} (C : B → Set k) (f : A → B) where

  ↓-ap-in : {x y : A} {p : x ≡ y} {u : C (f x)} {v : C (f y)}
    → u ≡[ C ◯ f ↓ p ] v
    → u ≡[ C ↓ ap f p ] v
  ↓-ap-in {p = refl} refl = refl

  ↓-ap-out : {x y : A} (p : x ≡ y) {u : C (f x)} {v : C (f y)}
    → u ≡[ C ↓ ap f p ] v
    → u ≡[ C ◯ f ↓ p ] v
  ↓-ap-out refl refl = refl

--  ↓-ap-β

ap-, : ∀ {i j k} {A : Set i} {B : Set j} {C : B → Set k}
  (f : A → B) (g : (a : A) → C (f a)) {x y : A} (p : x ≡ y)
  → ap (λ x → _,_ {P = C} (f x) (g x)) p
       ≡ Σ-eq (ap f p) (↓-ap-in C f (apd g p))
ap-, f g refl = refl
-}

-- Special case of [ap-,]
ap-cst,id : ∀ {i j} {A : Set i} (B : A → Set j)
  {a : A} {x y : B a} (p : x == y)
  → ap (λ x → _,_ {P = B} a x) p == Σ-eq refl p
ap-cst,id B refl = refl

-- apd-nd : ∀ {i j} {A : Set i} {B : Set j} (f : A → B) {x y : A}
--   → (p : x ≡ y) → apd f p ≡ ↓-cst-in p (ap f p)
-- apd-nd f refl = refl

apd-◯ : ∀ {i j k} {A : Set i} {B : A → Set j} {C : (a : A) → B a → Set k}
  (f : Π A B) (g : {a : A} → Π (B a) (C a)) {x y : A} (p : x == y)
  → apd (g ◯ f) p == ↓-apd-out C f p (apdd g p (apd f p))
apd-◯ f g refl = refl

{- Not used yet

-- apd-apd : ∀ {i j k} {A : Set i} {B : A → Set j} {C : (a : A) → B a → Set k}
--   (g : (u : Σ A B) → C (π₁ u) (π₂ u)) (f : Π A B) {x y : A} (p : x ≡ y)
--   → apd g (Σ-eq p (apd f p)) ≡ {!↓-ap-in!}
-- apd-apd = {!!}

apd-π₁-β : ∀ {i j} {A : Set i} {B : A → Set j} {x x' : A} (p : x ≡ x')
  {y : B x} {y' : B x'} (q : y ≡[ B ↓ p ] y')
  → ap π₁ (Σ-eq p q) ≡ p
apd-π₁-β refl refl = refl

apd-π₂-β : ∀ {i j} {A : Set i} {B : A → Set j} {x x' : A} (p : x ≡ x')
  {y : B x} {y' : B x'} (q : y ≡[ B ↓ p ] y')
  → apd π₂ (Σ-eq p q) ≡ ↓-ap-out B π₁ (Σ-eq p q)
    (transport (λ p → y ≡[ B ↓ p ] y') (! (apd-π₁-β p q)) q)
apd-π₂-β refl refl = refl
-}

-- Dependent path in a type of the form [λ x → g (f x) ≡ x]
module _ {i j} {A : Set i} {B : Set j} (f : A → B) (g : B → A) where
  ↓-◯=id-in : {x y : A} {p : x == y} {u : g (f x) == x} {v : g (f y) == y}
    → ((ap g (ap f p) ∘' v) == (u ∘ p))
    → (u == v [ (λ x → g (f x) == x) ↓ p ])
  ↓-◯=id-in {p = refl} q = ! (refl-right-unit _) ∘ (! q ∘ refl-left-unit _)

-- WIP, derive it from more primitive principles
-- ↓-◯≡id-in f g {p = p} {u} {v} q =
--   ↓-≡-in (u ◃ apd (λ x → g (f x)) p ≡⟨ apd-◯ f g p |in-ctx (λ t → u ◃ t) ⟩
--         u ◃ ↓-apd-out _ f p (apdd g p (apd f p)) ≡⟨ apdd-cst (λ _ b → g b) p (ap f p) (! (apd-nd f p)) |in-ctx (λ t → u ◃ ↓-apd-out _ f p t) ⟩
--         u ◃ ↓-apd-out _ f p (apd (λ t → g (π₂ t)) (Σ-eq p (apd f p))) ≡⟨ apd-◯ π₂ g (Σ-eq p (apd f p)) |in-ctx (λ t → u ◃ ↓-apd-out _ f p t) ⟩
--         u ◃ ↓-apd-out _ f p (↓-apd-out _ π₂ (Σ-eq p (apd f p)) (apdd g (Σ-eq p (apd f p)) (apd π₂ (Σ-eq p (apd f p))))) ≡⟨ {!!} ⟩
--         apd (λ x → x) p ▹ v ∎)

ua-in : ∀ {i} {A B : Set i} → A ≃ B → A == B
ua-in = eq-to-path

ua-out : ∀ {i} {A B : Set i} → A == B → A ≃ B
ua-out = path-to-eq

ua-β : ∀ {i} {A B : Set i} (e : A ≃ B)
  → ua-out (ua-in e) == e
ua-β e = eq-to-path-right-inverse e

-- These lemmas do not really look computational, but they are only used in the
-- [↓-pp] lemmas which do look computational.

to-transp-in : ∀ {i j} {A : Set i} (B : A → Set j)
  {a a' : A} (p : a == a')
  {u : B a} {v : B a'}
  → (π₁ (ua-out (ap B p)) u == v)
  → (u == v [ B ↓ p ])
to-transp-in B refl refl = refl

to-transp-out : ∀ {i j} {A : Set i} {B : A → Set j}
  {a a' : A} {p : a == a'}
  {u : B a} {v : B a'}
  → (u == v [ B ↓ p ])
  → (π₁ (ua-out (ap B p)) u == v)
to-transp-out {p = refl} refl = refl

to-transp-β : ∀ {i j} {A : Set i} (B : A → Set j)
  {a a' : A} (p : a == a')
  {u : B a} {v : B a'}
  (q : π₁ (ua-out (ap B p)) u == v)
  → to-transp-out (to-transp-in B p q) == q
to-transp-β B refl refl = refl

-- Stuff that do not belong here

ap-∘' : ∀ {i j} {A : Set i} {B : Set j} (f : A → B)
  {x y z : A} (p : x == y) (q : y == z)
  → ap f (p ∘' q) == (ap f p ∘' ap f q)
ap-∘' f refl refl = refl

-- Dependent concatenation'
_∘'dep_ : ∀ {i j} {A : Set i} {B : A → Set j}
  {x y z : A} {p : x == y} {p' : y == z}
  {u : B x} {v : B y} {w : B z}
  → (u == v [ B ↓ p ]
   → v == w [ B ↓ p' ]
   → u == w [ B ↓ (p ∘' p') ])
_∘'dep_ {p' = refl} q refl = q

-- Implementation of [_∘'_] on Σ
Σ-∘' : ∀ {i j} {A : Set i} {B : A → Set j}
  {x y z : A} {p : x == y} {p' : y == z}
  {u : B x} {v : B y} {w : B z}
  (q : u == v [ B ↓ p ]) (r : v == w [ B ↓ p' ])
  → (Σ-eq p q ∘' Σ-eq p' r) == Σ-eq (p ∘' p') (q ∘'dep r)
Σ-∘' {p' = refl} q refl = refl

-- No idea what that is
to-transp-weird : ∀ {i j} {A : Set i} {B : A → Set j}
  {u v : A} {d : B u} {d' d'' : B v} {p : u == v}
  (q : d == d' [ B ↓ p ]) (r : π₁ (ua-out (ap B p)) d == d'')
  → (to-transp-in B p r ∘'dep (! r ∘ to-transp-out q)) == q
to-transp-weird {p = refl} refl refl = refl

_∘'2_ : ∀ {i j} {A : Set i} {B : A → Set j} {a b c : Π A B}
  {x y : A} {p : x == y} {q : a x == b x} {q' : a y == b y}
  {r : b x == c x} {r' : b y == c y}
  → (q == q'            [ (λ z → a z == b z) ↓ p ])
  → (r == r'            [ (λ z → b z == c z) ↓ p ])
  → (q ∘' r == q' ∘' r' [ (λ z → a z == c z) ↓ p ])
_∘'2_ {p = refl} refl refl = refl

stuff : ∀ {i j} {A : Set i} {B : Set j} {b : B} {c : A → B} {d : A → B}
  (q : (a : A) → b == c a) (r : (a : A) → c a == d a) {a a' : A} (p : a == a')
  → apd (λ a → q a ∘' r a) p == ((apd q p) ∘'2 (apd r p))
stuff q r refl = refl

apd= : ∀ {i j} {A : Set i} {B : A → Set j} {f g : Π A B} (q : (x : A) → f x == g x) {x y : A} (p : x == y)
--    → (q x == q y [ (λ z → f z == g z) ↓ p ])
  → (apd f p ▹ q y) == (q x ◃ apd g p)
apd= q p = ! (↓-=-out (apd q p))
--apd= q refl =


{-# OPTIONS -v tc.unquote:30 #-}
open import Common.Prelude
open import Common.Reflection
open import Agda.Builtin.Sigma

data Box : Bool → Set where
  box : (b : Bool) → Box b

works : (b : Bool) → Box b → Bool
works b (box .b) = unquote (give (var 0 []))

works₂ : (b : Bool) → Box b → Bool
unquoteDef works₂ = defineFun works₂ (clause
  ( ("b" , vArg unknown) ∷ [])
  ( vArg (var 0)
  ∷ vArg (con (quote box)
        (vArg (dot unknown) ∷ []))
  ∷ [])
  (var 0 []) ∷ [])

works₃ : (b : Bool) → Box b → (x y : Bool) → Bool
unquoteDef works₃ = defineFun works₃ (clause
  ( ("y" , vArg unknown)
  ∷ ("x" , vArg unknown)
  ∷ ("b" , vArg unknown)
  ∷ [])
  ( vArg (var 2)
  ∷ vArg (con (quote box)
        (vArg (dot unknown) ∷ []))
  ∷ vArg (var 1)
  ∷ vArg (var 0)
  ∷ [])
  (var 2 []) ∷ [])


module PreludeInt where
open import AlonzoPrelude
import RTP

int : Nat -> Int
int = RTP.primNatToInt

_+_ : Int -> Int -> Int
_+_ = RTP.primIntAdd

_-_ : Int -> Int -> Int
_-_ = RTP.primIntSub

_*_ : Int -> Int -> Int
_*_ = RTP.primIntMul

div : Int -> Int -> Int
div = RTP.primIntDiv

mod : Int -> Int -> Int
mod = RTP.primIntMod


open import Data.List
open import Data.Unit

open import Relation.Unary hiding (_∈_)
open import Relation.Unary.PredicateTransformer using (Pt)
open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Construct.Market
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Morphisms

module Relation.Ternary.Separation.Monad.State.Heap
  {ℓ}

  -- value types
  {T : Set ℓ}

  -- stored values
  (V : T → Pred (List T) ℓ)
  where

open import Level hiding (Lift)
open import Function using (_∘_; case_of_)
import Relation.Binary.HeterogeneousEquality as HEq
open import Relation.Unary.PredicateTransformer hiding (_⊔_; [_])
open import Relation.Binary.PropositionalEquality using (refl; _≡_)
open import Relation.Ternary.Separation.Construct.Product
open import Relation.Ternary.Separation.Construct.List T
open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Allstar

open import Data.Product
open import Data.List.Relation.Ternary.Interleaving.Propositional as I

module HeapOps
  -- inner monad
  (M : Pt (Market (List T)) ℓ)
  {{monad : Monads.Monad ⊤ ℓ (λ _ _ → M) }}
  where
  Cells : Pred (List T × List T) ℓ
  Cells (Σ , Φ) = Allstar V Σ Φ

  open import Relation.Ternary.Separation.Monad.State
  open StateTransformer M public
  open Monads using (str)
  open Monads.Monad {{...}}

  -- Creating a reference to a new cell, filled with a given value.
  -- Note that in the market monoid this is pure!
  -- Because we get a reference that consumes the freshly created resource.
  newref : ∀ {a} → ∀[ V a ⇒ StateT M Cells (Just a) ]
  app (newref v) (lift st σ₁) (offerᵣ σ₂) =
    let _ , τ₁ , τ₂ = ⊎-assoc (⊎-comm σ₂) σ₁
    in return (
      inj refl
        ×⟨ offerᵣ ⊎-∙ ⟩
      lift (cons (v ×⟨ τ₂ ⟩ st)) (⊎-∙ₗ τ₁))

  -- A linear read on a store: you lose the reference.
  -- This is pure, because with the reference being lost, the cell is destroyed: no resources leak.
  read : ∀ {a} → ∀[ Just a ⇒ StateT M Cells (V a) ]
  app (read refl) (lift st σ₁) (offerᵣ σ₂) with ⊎-assoc σ₂ σ₁
  ... | _ , σ₃ , σ₄ with repartition σ₃ st
  ... | cons (v ×⟨ σ₅ ⟩ nil) ×⟨ σ₆ ⟩ st' with ⊎-id⁻ʳ σ₅ | ⊎-assoc (⊎-comm σ₆) (⊎-comm σ₄)
  ... | refl | _ , τ₁ , τ₂ = return (inj v ×⟨ offerᵣ τ₂ ⟩ lift st' (⊎-comm τ₁))

  -- Writing into a cell, returning the current contents
  write : ∀ {a b} → ∀[ Just b ✴ (V a) ⇒ StateT M Cells (Just a ✴ V b) ]
  app (write (refl ×⟨ σ₁ ⟩ v)) (lift st σ₂) (offerᵣ σ₃) with ⊎-assoc (⊎-comm σ₁) σ₃
  -- first we reassociate the arguments in the order that we want to piece it back together
  ... | _ , τ₁ , τ₂ with ⊎-assoc (⊎-comm τ₁) σ₂
  ... | _ , τ₃ , τ₄ with ⊎-assoc τ₂ τ₃
  ... | _ , τ₅ , τ₆
  -- then we reorganize the store internally to take out the unit value
    with repartition τ₅ st
  ... | cons (vb ×⟨ σ₅ ⟩ nil) ×⟨ σ₆ ⟩ st' rewrite ⊎-id⁻ʳ σ₅ =
    let
      _ , κ₁ , κ₂ = ⊎-unassoc τ₄ (⊎-comm σ₆)
      _ , κ₃ , κ₄ = ⊎-assoc κ₂ (⊎-comm τ₆)
    in return (
      inj (refl ×⟨ consˡ ⊎-idˡ ⟩ vb)
        ×⟨ offerᵣ (consˡ κ₄) ⟩
      lift (cons (v ×⟨ κ₁ ⟩ st')) (⊎-∙ₗ (⊎-comm κ₃)))

  -- A linear (strong) update on the store
  update! : ∀ {a b} → ∀[ Just a ⇒ (V a ─✴ StateT M Cells (V b)) ─✴ StateT M Cells (Just b) ]
  app (update! ptr) f σ = do
    a ×⟨ σ₁ ⟩ f ← read ptr &⟨ σ ⟩ f
    b           ← app f a (⊎-comm σ₁)
    newref b


module Data.QuadTree.LensProofs.Valid-LensBCD where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.InternalAgda
open import Agda.Primitive
open import Data.Lens.Proofs.LensLaws
open import Data.Lens.Proofs.LensPostulates
open import Data.Lens.Proofs.LensComposition
open import Data.QuadTree.Implementation.QuadrantLenses
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.SafeFunctions
open import Data.QuadTree.Implementation.PublicFunctions
open import Data.QuadTree.Implementation.DataLenses

-- The lens laws have been proven for LensA, and the proof is quite long.
-- The implementation of lens b/c/d is basically identical, so I won't bother to proof them for now

--- Lens laws for lensB

postulate
    ValidLens-LensB-ViewSet :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> ViewSet (lensB {t} {dep})
    ValidLens-LensB-SetView :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> SetView (lensB {t} {dep})
    ValidLens-LensB-SetSet :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> SetSet (lensB {t} {dep})

ValidLens-LensB : {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> ValidLens (VQuadrant t {S dep}) (VQuadrant t {dep})
ValidLens-LensB {t} {dep} = CValidLens lensB (ValidLens-LensB-ViewSet) (ValidLens-LensB-SetView) (ValidLens-LensB-SetSet)

--- Lens laws for lensC

postulate
    ValidLens-LensC-ViewSet :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> ViewSet (lensC {t} {dep})
    ValidLens-LensC-SetView :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> SetView (lensC {t} {dep})
    ValidLens-LensC-SetSet :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> SetSet (lensC {t} {dep})

ValidLens-LensC : {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> ValidLens (VQuadrant t {S dep}) (VQuadrant t {dep})
ValidLens-LensC {t} {dep} = CValidLens lensC (ValidLens-LensC-ViewSet) (ValidLens-LensC-SetView) (ValidLens-LensC-SetSet)

--- Lens laws for lensD

postulate
    ValidLens-LensD-ViewSet :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> ViewSet (lensD {t} {dep})
    ValidLens-LensD-SetView :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> SetView (lensD {t} {dep})
    ValidLens-LensD-SetSet :
        {t : Set} {{eqT : Eq t}} {dep : Nat}
        -> SetSet (lensD {t} {dep})

ValidLens-LensD : {t : Set} {{eqT : Eq t}} {dep : Nat}
    -> ValidLens (VQuadrant t {S dep}) (VQuadrant t {dep})
ValidLens-LensD {t} {dep} = CValidLens lensD (ValidLens-LensD-ViewSet) (ValidLens-LensD-SetView) (ValidLens-LensD-SetSet)


{-

This file contains:

- Properties of set truncations

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SetTruncation.Properties where

open import Cubical.HITs.SetTruncation.Base

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation
  renaming (rec to pRec ; elim to pElim) hiding (elim2 ; elim3 ; rec2 ; map)

private
  variable
    ℓ ℓ' ℓ'' : Level
    A B C D : Type ℓ

rec : isSet B → (A → B) → ∥ A ∥₂ → B
rec Bset f ∣ x ∣₂ = f x
rec Bset f (squash₂ x y p q i j) =
  Bset _ _ (cong (rec Bset f) p) (cong (rec Bset f) q) i j

rec2 : isSet C → (A → B → C) → ∥ A ∥₂ → ∥ B ∥₂ → C
rec2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y
rec2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) =
  Cset _ _ (cong (rec2 Cset f ∣ x ∣₂) p) (cong (rec2 Cset f ∣ x ∣₂) q) i j
rec2 Cset f (squash₂ x y p q i j) z =
  Cset _ _ (cong (λ a → rec2 Cset f a z) p) (cong (λ a → rec2 Cset f a z) q) i j

-- Old version:
-- rec2 Cset f = rec (isSetΠ λ _ → Cset) λ x → rec Cset (f x)

-- lemma 6.9.1 in HoTT book
elim : {B : ∥ A ∥₂ → Type ℓ}
       (Bset : (x : ∥ A ∥₂) → isSet (B x))
       (f : (a : A) → B (∣ a ∣₂))
       (x : ∥ A ∥₂) → B x
elim Bset f ∣ a ∣₂ = f a
elim Bset f (squash₂ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 Bset _ _
    (cong (elim Bset f) p) (cong (elim Bset f) q) (squash₂ x y p q) i j

elim2 : {C : ∥ A ∥₂ → ∥ B ∥₂ → Type ℓ}
        (Cset : ((x : ∥ A ∥₂) (y : ∥ B ∥₂) → isSet (C x y)))
        (f : (a : A) (b : B) → C ∣ a ∣₂ ∣ b ∣₂)
        (x : ∥ A ∥₂) (y : ∥ B ∥₂) → C x y
elim2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y
elim2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) =
  isOfHLevel→isOfHLevelDep 2 (λ a → Cset ∣ x ∣₂ a) _ _
     (cong (elim2 Cset f ∣ x ∣₂) p) (cong (elim2 Cset f ∣ x ∣₂) q) (squash₂ y z p q) i j
elim2 Cset f (squash₂ x y p q i j) z =
  isOfHLevel→isOfHLevelDep 2 (λ a → Cset a z) _ _
    (cong (λ a → elim2 Cset f a z) p) (cong (λ a → elim2 Cset f a z) q) (squash₂ x y p q) i j

-- Old version:
-- elim2 Cset f = elim (λ _ → isSetΠ (λ _ → Cset _ _))
--                     (λ a → elim (λ _ → Cset _ _) (f a))

-- TODO: generalize
elim3 : {B : (x y z : ∥ A ∥₂) → Type ℓ}
        (Bset : ((x y z : ∥ A ∥₂) → isSet (B x y z)))
        (g : (a b c : A) → B ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂)
        (x y z : ∥ A ∥₂) → B x y z
elim3 Bset g = elim2 (λ _ _ → isSetΠ (λ _ → Bset _ _ _))
                     (λ a b → elim (λ _ → Bset _ _ _) (g a b))

-- the recursor for maps into groupoids following the "HIT proof" in:
-- https://arxiv.org/abs/1507.01150
-- i.e. for any type A and groupoid B we can construct a map ∥ A ∥₂ → B
-- from a map A → B satisfying the condition
--    ∀ (a b : A) (p q : a ≡ b) → cong f p ≡ cong f q
-- TODO: prove that this is an equivalence
module rec→Gpd {A : Type ℓ} {B : Type ℓ'} (Bgpd : isGroupoid B) (f : A → B)
               (congFConst : ∀ (a b : A) (p q : a ≡ b) → cong f p ≡ cong f q) where

 data H : Type ℓ where
  η : A → H
  ε : ∀ (a b : A) → ∥ a ≡ b ∥ → η a ≡ η b -- prop. trunc. of a≡b
  δ : ∀ (a b : A) (p : a ≡ b) → ε a b ∣ p ∣ ≡ cong η p
  gtrunc : isGroupoid H

 -- write elimination principle for H
 module Helim {P : H → Type ℓ''} (Pgpd : ∀ h → isGroupoid (P h))
              (η* : (a : A) → P (η a))
              (ε* : ∀ (a b : A) (∣p∣ : ∥ a ≡ b ∥)
                  → PathP (λ i → P (ε a b ∣p∣ i)) (η* a) (η* b))
              (δ* : ∀ (a b : A) (p : a ≡ b)
                  → PathP (λ i → PathP (λ j → P (δ a b p i j)) (η* a) (η* b))
                          (ε* a b ∣ p ∣) (cong η* p)) where

  fun : (h : H) → P h
  fun (η a) = η* a
  fun (ε a b ∣p∣ i) = ε* a b ∣p∣ i
  fun (δ a b p i j) = δ* a b p i j
  fun (gtrunc x y p q α β i j k) = isOfHLevel→isOfHLevelDep 3 Pgpd
                                   (fun x) (fun y)
                                   (cong fun p) (cong fun q)
                                   (cong (cong fun) α) (cong (cong fun) β)
                                   (gtrunc x y p q α β) i j k

 module Hrec {C : Type ℓ''} (Cgpd : isGroupoid C)
             (η* : A → C)
             (ε* : ∀ (a b : A) → ∥ a ≡ b ∥ → η* a ≡ η* b)
             (δ* : ∀ (a b : A) (p : a ≡ b) → ε* a b ∣ p ∣ ≡ cong η* p) where

  fun : H → C
  fun (η a) = η* a
  fun (ε a b ∣p∣ i) = ε* a b ∣p∣ i
  fun (δ a b p i j) = δ* a b p i j
  fun (gtrunc x y p q α β i j k) = Cgpd (fun x) (fun y) (cong fun p) (cong fun q)
                                   (cong (cong fun) α) (cong (cong fun) β) i j k

 module HelimProp {P : H → Type ℓ''} (Pprop : ∀ h → isProp (P h))
                  (η* : (a : A) → P (η a)) where

  fun : ∀ h → P h
  fun = Helim.fun (λ _ → isSet→isGroupoid (isProp→isSet (Pprop _))) η*
                  (λ a b ∣p∣ → isOfHLevel→isOfHLevelDep 1 Pprop _ _ (ε a b ∣p∣))
                   λ a b p → isOfHLevel→isOfHLevelDep 1
                              {B = λ p → PathP (λ i → P (p i)) (η* a) (η* b)}
                              (λ _ → isOfHLevelPathP 1 (Pprop _) _ _) _ _ (δ a b p)

 -- The main trick: eliminating into hsets is easy
 -- i.e. H has the universal property of set truncation...
 module HelimSet {P : H → Type ℓ''} (Pset : ∀ h → isSet (P h))
                 (η* : ∀ a → P (η a)) where

  fun : (h : H) → P h
  fun = Helim.fun (λ _ → isSet→isGroupoid (Pset _)) η* ε*
                   λ a b p → isOfHLevel→isOfHLevelDep 1
                             {B = λ p → PathP (λ i → P (p i)) (η* a) (η* b)}
                             (λ _ → isOfHLevelPathP' 1 (Pset _) _ _) _ _ (δ a b p)
   where
   ε* : (a b : A) (∣p∣ : ∥ a ≡ b ∥) → PathP (λ i → P (ε a b ∣p∣ i)) (η* a) (η* b)
   ε* a b = pElim (λ _ → isOfHLevelPathP' 1 (Pset _) (η* a) (η* b))
                   λ p → subst (λ x → PathP (λ i → P (x i)) (η* a) (η* b))
                               (sym (δ a b p)) (cong η* p)

 -- Now we need to prove that H is a set.
 -- We start with a  little lemma:
 localHedbergLemma : {X : Type ℓ''} (P : X → Type ℓ'')
                   → (∀ x → isProp (P x))
                   → ((x : X) → P x → (y : X) → P y → x ≡ y)
                  --------------------------------------------------
                   → (x : X) → P x → (y : X) → isProp (x ≡ y)
 localHedbergLemma {X = X} P Pprop P→≡ x px y = isPropRetract
                   (λ p → subst P p px) (λ py → sym (P→≡ x px x px) ∙ P→≡ x px y py)
                   isRetract (Pprop y)
  where
  isRetract : (p : x ≡ y) → (sym (P→≡ x px x px)) ∙ P→≡ x px y (subst P p px) ≡ p
  isRetract = J (λ y' p' → (sym (P→≡ x px x px)) ∙ P→≡ x px y' (subst P p' px) ≡ p')
                (subst (λ px' → sym (P→≡ x px x px) ∙ P→≡ x px x px' ≡ refl)
                (sym (substRefl {B = P} px)) (lCancel (P→≡ x px x px)))

 Hset : isSet H
 Hset = HelimProp.fun (λ _ → isPropΠ λ _ → isPropIsProp) baseCaseLeft
  where
  baseCaseLeft : (a₀ : A) (y : H) → isProp (η a₀ ≡ y)
  baseCaseLeft a₀ = localHedbergLemma (λ x → Q x .fst) (λ x → Q x .snd) Q→≡ _ ∣ refl ∣
   where
   Q : H → hProp ℓ
   Q = HelimSet.fun (λ _ → isSetHProp) λ b → ∥ a₀ ≡ b ∥ , propTruncIsProp
   -- Q (η b) = ∥ a ≡ b ∥

   Q→≡ : (x : H) → Q x .fst → (y : H) → Q y .fst → x ≡ y
   Q→≡ = HelimSet.fun (λ _ → isSetΠ3 λ _ _ _ → gtrunc _ _)
       λ a p → HelimSet.fun (λ _ → isSetΠ λ _ → gtrunc _ _)
       λ b q → sym (ε a₀ a p) ∙ ε a₀ b q

 -- our desired function will split through H,
 -- i.e. we get a function ∥ A ∥₂ → H → B
 fun : ∥ A ∥₂ → B
 fun = f₁ ∘ f₂
  where
  f₁ : H → B
  f₁ = Hrec.fun Bgpd f εᶠ λ _ _ _ → refl
   where
   εᶠ : (a b : A) → ∥ a ≡ b ∥ → f a ≡ f b
   εᶠ a b = rec→Set (Bgpd _ _) (cong f) λ p q → congFConst a b p q
   -- this is the inductive step,
   -- we use that maps ∥ A ∥ → B for an hset B
   -- correspond to 2-Constant maps A → B (which cong f is by assumption)
  f₂ : ∥ A ∥₂ → H
  f₂ = rec Hset η

map : (A → B) → ∥ A ∥₂ → ∥ B ∥₂
map f = rec squash₂ λ x → ∣ f x ∣₂

setTruncUniversal : isSet B → (∥ A ∥₂ → B) ≃ (A → B)
setTruncUniversal {B = B} Bset =
  isoToEquiv (iso (λ h x → h ∣ x ∣₂) (rec Bset) (λ _ → refl) rinv)
  where
  rinv : (f : ∥ A ∥₂ → B) → rec Bset (λ x → f ∣ x ∣₂) ≡ f
  rinv f i x =
    elim (λ x → isProp→isSet (Bset (rec Bset (λ x → f ∣ x ∣₂) x) (f x)))
         (λ _ → refl) x i

setTruncIsSet : isSet ∥ A ∥₂
setTruncIsSet a b p q = squash₂ a b p q

setTruncIdempotentIso : isSet A → Iso ∥ A ∥₂ A
Iso.fun (setTruncIdempotentIso hA) = rec hA (idfun _)
Iso.inv (setTruncIdempotentIso hA) x = ∣ x ∣₂
Iso.rightInv (setTruncIdempotentIso hA) _ = refl
Iso.leftInv (setTruncIdempotentIso hA) = elim (λ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ → refl)

setTruncIdempotent≃ : isSet A → ∥ A ∥₂ ≃ A
setTruncIdempotent≃ {A = A} hA = isoToEquiv (setTruncIdempotentIso hA)

setTruncIdempotent : isSet A → ∥ A ∥₂ ≡ A
setTruncIdempotent hA = ua (setTruncIdempotent≃ hA)

isContr→isContrSetTrunc : isContr A → isContr (∥ A ∥₂)
isContr→isContrSetTrunc contr = ∣ fst contr ∣₂
                                , elim (λ _ → isOfHLevelPath 2 (setTruncIsSet) _ _)
                                       λ a → cong ∣_∣₂ (snd contr a)

setTruncIso : Iso A B → Iso ∥ A ∥₂ ∥ B ∥₂
Iso.fun (setTruncIso is) = rec setTruncIsSet (λ x → ∣ Iso.fun is x ∣₂)
Iso.inv (setTruncIso is) = rec setTruncIsSet (λ x → ∣ Iso.inv is x ∣₂)
Iso.rightInv (setTruncIso is) =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ a → cong ∣_∣₂ (Iso.rightInv is a)
Iso.leftInv (setTruncIso is) =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ a → cong ∣_∣₂ (Iso.leftInv is a)

setSigmaIso : {B : A → Type ℓ} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
setSigmaIso {A = A} {B = B} = iso fun funinv sect retr
  where
  {- writing it out explicitly to avoid yellow highlighting -}
  fun : ∥ Σ A B ∥₂ → ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
  fun = rec setTruncIsSet λ {(a , p) → ∣ a , ∣ p ∣₂ ∣₂}
  funinv : ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ → ∥ Σ A B ∥₂
  funinv = rec setTruncIsSet (λ {(a , p) → rec setTruncIsSet (λ p → ∣ a , p ∣₂) p})
  sect : section fun funinv
  sect = elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
              λ { (a , p) → elim {B = λ p → fun (funinv ∣ a , p ∣₂) ≡ ∣ a , p ∣₂}
              (λ p → isOfHLevelPath 2 setTruncIsSet _ _) (λ _ → refl) p }
  retr : retract fun funinv
  retr = elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
              λ { _ → refl }

sigmaElim : {B : ∥ A ∥₂ → Type ℓ} {C : Σ ∥ A ∥₂ B  → Type ℓ'}
            (Bset : (x : Σ ∥ A ∥₂ B) → isSet (C x))
            (g : (a : A) (b : B ∣ a ∣₂) → C (∣ a ∣₂ , b))
            (x : Σ ∥ A ∥₂ B) → C x
sigmaElim {B = B} {C = C} set g (x , y) =
  elim {B = λ x → (y : B x) → C (x , y)} (λ _ → isSetΠ λ _ → set _) g x y

sigmaProdElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} {D : Σ (∥ A ∥₂ × ∥ B ∥₂) C  → Type ℓ'}
                (Bset : (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → isSet (D x))
                (g : (a : A) (b : B) (c : C (∣ a ∣₂ , ∣ b ∣₂)) → D ((∣ a ∣₂ , ∣ b ∣₂) , c))
                (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → D x
sigmaProdElim {B = B} {C = C} {D = D} set g ((x , y) , c) =
  elim {B = λ x → (y : ∥ B ∥₂) (c : C (x , y)) → D ((x , y) , c)}
       (λ _ → isSetΠ λ _ → isSetΠ λ _ → set _)
       (λ x → elim (λ _ → isSetΠ λ _ → set _) (g x))
       x y c

prodElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ}
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) → isSet (C x))
         → ((a : A) (b : B) → C (∣ a ∣₂ , ∣ b ∣₂))
         → (x : ∥ A ∥₂ × ∥ B ∥₂) → C x
prodElim setC f (a , b) = elim2 (λ x y → setC (x , y)) f a b

prodRec : {C : Type ℓ} → isSet C → (A → B → C) → ∥ A ∥₂ × ∥ B ∥₂ → C
prodRec setC f (a , b) = rec2 setC f a b

prodElim2 : {E : (∥ A ∥₂ × ∥ B ∥₂) → (∥ C ∥₂ × ∥ D ∥₂) → Type ℓ}
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → isSet (E x y))
         → ((a : A) (b : B) (c : C) (d : D) → E (∣ a ∣₂ , ∣ b ∣₂) (∣ c ∣₂ , ∣ d ∣₂))
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → (E x y))
prodElim2 isset f = prodElim (λ _ → isSetΠ λ _ → isset _ _)
                             λ a b → prodElim (λ _ → isset _ _)
                                     λ c d → f a b c d

setTruncOfProdIso :  Iso ∥ A × B ∥₂ (∥ A ∥₂ × ∥ B ∥₂)
Iso.fun setTruncOfProdIso = rec (isSet× setTruncIsSet setTruncIsSet) λ { (a , b) → ∣ a ∣₂ , ∣ b ∣₂ }
Iso.inv setTruncOfProdIso = prodRec setTruncIsSet λ a b → ∣ a , b ∣₂
Iso.rightInv setTruncOfProdIso =
  prodElim (λ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _) λ _ _ → refl
Iso.leftInv setTruncOfProdIso =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _) λ {(a , b) → refl}

IsoSetTruncateSndΣ : {A : Type ℓ} {B : A → Type ℓ'} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
Iso.fun IsoSetTruncateSndΣ = map λ a → (fst a) , ∣ snd a ∣₂
Iso.inv IsoSetTruncateSndΣ = rec setTruncIsSet (uncurry λ x → map λ b → x , b)
Iso.rightInv IsoSetTruncateSndΣ =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        (uncurry λ a → elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ _ → refl)
Iso.leftInv IsoSetTruncateSndΣ =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
         λ _ → refl

PathIdTrunc₀Iso : {a b : A} → Iso (∣ a ∣₂ ≡ ∣ b ∣₂) ∥ a ≡ b ∥
Iso.fun (PathIdTrunc₀Iso {b = b}) p =
  transport (λ i → rec {B = TypeOfHLevel _ 1} (isOfHLevelTypeOfHLevel 1)
                        (λ a → ∥ a ≡ b ∥ , squash) (p (~ i)) .fst)
            ∣ refl ∣
Iso.inv PathIdTrunc₀Iso = pRec (squash₂ _ _) (cong ∣_∣₂)
Iso.rightInv PathIdTrunc₀Iso _ = squash _ _
Iso.leftInv PathIdTrunc₀Iso _ = squash₂ _ _ _ _


------------------------------------------------------------------------
-- The Agda standard library
--
-- The state monad
------------------------------------------------------------------------

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

module Category.Monad.State where

open import Category.Applicative.Indexed
open import Category.Monad
open import Function.Identity.Categorical as Id using (Identity)
open import Category.Monad.Indexed
open import Data.Product
open import Data.Unit
open import Function
open import Level

------------------------------------------------------------------------
-- Indexed state

IStateT : ∀ {i f} {I : Set i} → (I → Set f) → (Set f → Set f) → IFun I f
IStateT S M i j A = S i → M (A × S j)

------------------------------------------------------------------------
-- Indexed state applicative

StateTIApplicative : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
                     RawMonad M → RawIApplicative (IStateT S M)
StateTIApplicative S Mon = record
  { pure = λ a s → return (a , s)
  ; _⊛_  = λ f t s → do
     (f′ , s′)  ← f s
     (t′ , s′′) ← t s′
     return (f′ t′ , s′′)
  } where open RawMonad Mon

StateTIApplicativeZero : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
                         RawMonadZero M → RawIApplicativeZero (IStateT S M)
StateTIApplicativeZero S Mon = record
  { applicative = StateTIApplicative S monad
  ; ∅           = const ∅
  } where open RawMonadZero Mon

StateTIAlternative : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
                     RawMonadPlus M → RawIAlternative (IStateT S M)
StateTIAlternative S Mon = record
  { applicativeZero = StateTIApplicativeZero S monadZero
  ; _∣_             = λ m n s → m s ∣ n s
  } where open RawMonadPlus Mon

------------------------------------------------------------------------
-- Indexed state monad

StateTIMonad : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
               RawMonad M → RawIMonad (IStateT S M)
StateTIMonad S Mon = record
  { return = λ x s → return (x , s)
  ; _>>=_  = λ m f s → m s >>= uncurry f
  } where open RawMonad Mon

StateTIMonadZero : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
                   RawMonadZero M → RawIMonadZero (IStateT S M)
StateTIMonadZero S Mon = record
  { monad           = StateTIMonad S (RawMonadZero.monad Mon)
  ; applicativeZero = StateTIApplicativeZero S Mon
  } where open RawMonadZero Mon

StateTIMonadPlus : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
                   RawMonadPlus M → RawIMonadPlus (IStateT S M)
StateTIMonadPlus S Mon = record
  { monad       = StateTIMonad S monad
  ; alternative = StateTIAlternative S Mon
  } where open RawMonadPlus Mon

------------------------------------------------------------------------
-- State monad operations

record RawIMonadState {i f} {I : Set i} (S : I → Set f)
                      (M : IFun I f) : Set (i ⊔ suc f) where
  field
    monad : RawIMonad M
    get   : ∀ {i} → M i i (S i)
    put   : ∀ {i j} → S j → M i j (Lift f ⊤)

  open RawIMonad monad public

  modify : ∀ {i j} → (S i → S j) → M i j (Lift f ⊤)
  modify f = get >>= put ∘ f

StateTIMonadState : ∀ {i f} {I : Set i} (S : I → Set f) {M} →
                    RawMonad M → RawIMonadState S (IStateT S M)
StateTIMonadState S Mon = record
  { monad = StateTIMonad S Mon
  ; get   = λ s   → return (s , s)
  ; put   = λ s _ → return (_ , s)
  }
  where open RawIMonad Mon

------------------------------------------------------------------------
-- Ordinary state monads

RawMonadState : ∀ {f} → Set f → (Set f → Set f) → Set _
RawMonadState S M = RawIMonadState {I = ⊤} (λ _ → S) (λ _ _ → M)

module RawMonadState {f} {S : Set f} {M : Set f → Set f}
                     (Mon : RawMonadState S M) where
  open RawIMonadState Mon public

StateT : ∀ {f} → Set f → (Set f → Set f) → Set f → Set f
StateT S M = IStateT {I = ⊤} (λ _ → S) M _ _

StateTMonad : ∀ {f} (S : Set f) {M} → RawMonad M → RawMonad (StateT S M)
StateTMonad S = StateTIMonad (λ _ → S)

StateTMonadZero : ∀ {f} (S : Set f) {M} →
                  RawMonadZero M → RawMonadZero (StateT S M)
StateTMonadZero S = StateTIMonadZero (λ _ → S)

StateTMonadPlus : ∀ {f} (S : Set f) {M} →
                  RawMonadPlus M → RawMonadPlus (StateT S M)
StateTMonadPlus S = StateTIMonadPlus (λ _ → S)

StateTMonadState : ∀ {f} (S : Set f) {M} →
                   RawMonad M → RawMonadState S (StateT S M)
StateTMonadState S = StateTIMonadState (λ _ → S)

State : ∀ {f} → Set f → Set f → Set f
State S = StateT S Identity

StateMonad : ∀ {f} (S : Set f) → RawMonad (State S)
StateMonad S = StateTMonad S Id.monad

StateMonadState : ∀ {f} (S : Set f) → RawMonadState S (State S)
StateMonadState S = StateTMonadState S Id.monad

LiftMonadState : ∀ {f S₁} (S₂ : Set f) {M} →
                 RawMonadState S₁ M →
                 RawMonadState S₁ (StateT S₂ M)
LiftMonadState S₂ Mon = record
  { monad = StateTIMonad (λ _ → S₂) monad
  ; get   = λ s → get >>= λ x → return (x , s)
  ; put   = λ s′ s → put s′ >> return (_ , s)
  }
  where open RawIMonadState Mon


module Tactic.Reflection.Replace where
  open import Prelude

  open import Container.Traversable

  open import Tactic.Reflection
  open import Tactic.Reflection.Equality

  {-# TERMINATING #-}
  _r[_/_] : Term → Term → Term → Term
  p r[ r / l ] =
    ifYes p == l
      then r
      else case p of λ
        { (var x args) → var x $ args r₂[ r / l ]
        ; (con c args) → con c $ args r₂[ r / l ]
        ; (def f args) → def f $ args r₂[ r / l ]
        ; (lam v t) → lam v $ t r₁[ weaken 1 r / weaken 1 l ] -- lam v <$> t r₁[ weaken 1 r / weaken 1 l ]
        ; (pat-lam cs args) →
            let w = length args in
            pat-lam (replaceClause (weaken w l) (weaken w r) <$> cs) $ args r₂[ r / l ]
        ; (pi a b) → pi (a r₁[ r / l ]) (b r₁[ weaken 1 r / weaken 1 l ])
        ; (agda-sort s) → agda-sort $ replaceSort l r s
        ; (lit l) → lit l
        ; (meta x args) → meta x $ args r₂[ r / l ]
        ; unknown → unknown
        }
      where

      replaceClause : Term → Term → Clause → Clause
      replaceClause l r (clause pats x) = clause pats $ x r[ r / l ]
      replaceClause l r (absurd-clause pats) = absurd-clause pats

      replaceSort : Term → Term → Sort → Sort
      replaceSort l r (set t) = set $ t r[ r / l ]
      replaceSort l r (lit n) = lit n
      replaceSort l r unknown = unknown

      _r₁[_/_] : {T₀ : Set → Set} {{_ : Traversable T₀}} → T₀ Term → Term → Term → T₀ Term
      p r₁[ r / l ] = _r[ r / l ] <$> p

      _r₂[_/_] : {T₀ T₁ : Set → Set} {{_ : Traversable T₀}} {{_ : Traversable T₁}} →
                 T₁ (T₀ Term) → Term → Term → T₁ (T₀ Term)
      p r₂[ r / l ] = fmap _r[ r / l ] <$> p

  _R[_/_] : List (Arg Type) → Type → Type → List (Arg Type)
  Γ R[ L / R ] = go Γ (strengthen 1 L) (strengthen 1 R) where
    go : List (Arg Type) → Maybe Term → Maybe Term → List (Arg Type)
    go (γ ∷ Γ) (just L) (just R) = (caseF γ of _r[ L / R ]) ∷ go Γ (strengthen 1 L) (strengthen 1 R)
    go Γ _ _ = Γ


{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
open import Function
module Spire.Examples.PropLev where

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Branches : (E : Enum) (P : Tag E → Set) → Set
Branches [] P = ⊤
Branches (l ∷ E) P = P here × Branches E (λ t → P (there t))

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches [] P X = X
CurriedBranches (l ∷ E) P X = P here → CurriedBranches E (λ t → P (there t)) X

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

data Desc (I : Set) : Set₁ where
  End : (i : I) → Desc I
  Rec : (i : I) (D : Desc I) → Desc I
  Arg : (A : Set) (B : A → Desc I) → Desc I

elimDesc : {I : Set} (P : Desc I → Set)
  (pend : (i : I) → P (End i))
  (prec : (i : I) (D : Desc I) (pd : P D) → P (Rec i D))
  (parg : (A : Set) (B : A → Desc I) (pb : (a : A) → P (B a)) → P (Arg A B))
  (D : Desc I) → P D
elimDesc P pend prec parg (End i) = pend i
elimDesc P pend prec parg (Rec i D) = prec i D (elimDesc P pend prec parg D)
elimDesc P pend prec parg (Arg A B) = parg A B (λ a → elimDesc P pend prec parg (B a))

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

ISet : Set → Set₁
ISet I = I → Set

El : {I : Set} (D : Desc I) → ISet I → ISet I
El (End j) X i = j ≡ i
El (Rec j D) X i = X j × El D X i
El (Arg A B) X i = Σ A (λ a → El (B a) X i)

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El D X i) → Set
Hyps (End j) X P i q = ⊤
Hyps (Rec j D) X P i (x , xs) = P j x × Hyps D X P i xs
Hyps (Arg A B) X P i (a , b) = Hyps (B a) X P i b

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

UncurriedEl : {I : Set} (D : Desc I) (X : ISet I) → Set
UncurriedEl D X = ∀{i} → El D X i → X i

CurriedEl : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedEl (End i) X = X i
CurriedEl (Rec i D) X = (x : X i) → CurriedEl D X
CurriedEl (Arg A B) X = (a : A) → CurriedEl (B a) X

curryEl : {I : Set} (D : Desc I) (X : ISet I)
  → UncurriedEl D X → CurriedEl D X
curryEl (End i) X cn = cn refl
curryEl (Rec i D) X cn = λ x → curryEl D X (λ xs → cn (x , xs))
curryEl (Arg A B) X cn = λ a → curryEl (B a) X (λ xs → cn (a , xs))

uncurryEl : {I : Set} (D : Desc I) (X : ISet I)
  → CurriedEl D X → UncurriedEl D X
uncurryEl (End i) X cn refl = cn
uncurryEl (Rec i D) X cn (x , xs) = uncurryEl D X (cn x) xs
uncurryEl (Arg A B) X cn (a , xs) = uncurryEl (B a) X (cn a) xs

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : El D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → Set
CurriedHyps (End i) X P cn =
  P i (cn refl)
CurriedHyps (Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps D X P (λ xs → cn (x , xs))
CurriedHyps (Arg A B) X P cn =
  (a : A) → CurriedHyps (B a) X P (λ xs → cn (a , xs))

curryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → UncurriedHyps D X P cn
  → CurriedHyps D X P cn
curryHyps (End i) X P cn pf =
  pf i refl tt
curryHyps (Rec i D) X P cn pf =
  λ x ih → curryHyps D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps (Arg A B) X P cn pf =
  λ a → curryHyps (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps (End .i) X P cn pf i refl tt =
  pf
uncurryHyps (Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps (Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs

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

data μ {I : Set} (D : Desc I) : ISet I where
  init : UncurriedEl D (μ D)

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

Data : Set
Data =
  Σ Set λ I →
  Σ Enum λ E →
  Branches E (λ _ → Desc I)

DataI : Data → Set
DataI (I , E , B) = I

DataE : Data → Enum
DataE (I , E , B) = E

DataT : Data → Set
DataT R = Tag (DataE R)

DataB : (R : Data) → Branches (DataE R) (λ _ → Desc (DataI R))
DataB (I , E , B) = B

DataD : (R : Data) → Desc (DataI R)
DataD R = Arg (DataT R) (case (λ _ → Desc (DataI R)) (DataB R))

caseR : (R : Data) → DataT R → Desc (DataI R)
caseR R = case (λ _ → Desc (DataI R)) (DataB R)

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

inj : (R : Data)
  → let D = DataD R
  in CurriedEl D (μ D)
inj R = let D = DataD R
  in curryEl D (μ D) init

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

ind : {I : Set} (D : Desc I)
  (P : (i : I) → μ D i → Set)
  (α : UncurriedHyps D (μ D) P init)
  (i : I)
  (x : μ D i)
  → P i x

prove : {I : Set} (D E : Desc I)
  (P : (i : I) → μ E i → Set)
  (α : UncurriedHyps E (μ E) P init)
  (i : I) (xs : El D (μ E) i) → Hyps D (μ E) P i xs

ind D P α i (init xs) = α i xs (prove D D P α i xs)

prove (End j) E P α i q = tt
prove (Rec j D) E P α i (x , xs) = ind E P α j x , prove D E P α i xs
prove (Arg A B) E P α i (a , xs) = prove (B a) E P α i xs

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

indCurried : {I : Set} (D : Desc I)
  (P : (i : I) → μ D i → Set)
  (f : CurriedHyps D (μ D) P init)
  (i : I)
  (x : μ D i)
  → P i x
indCurried D P f i x = ind D P (uncurryHyps D (μ D) P init f) i x

SumCurriedHyps : (R : Data)
  → let D = DataD R in
  (P : ∀ i → μ D i → Set)
  → DataT R → Set
SumCurriedHyps R P t =
  CurriedHyps (caseR R t) (μ (DataD R)) P (λ xs → init (t , xs))

elimUncurried : (R : Data)
  → let D = DataD R in
  (P : ∀ i → μ D i → Set)
  → UncurriedBranches (DataE R)
    (SumCurriedHyps R P)
    (∀ i (x : μ D i) → P i x)
elimUncurried R P cs i x =
  indCurried (DataD R) P
    (case (SumCurriedHyps R P) cs)
    i x

elim : (R : Data)
  → let D = DataD R in
  (P : ∀ i → μ D i → Set)
  → CurriedBranches (DataE R)
      (SumCurriedHyps R P)
      (∀ i (x : μ D i) → P i x)
elim R P = curryBranches (elimUncurried R P)

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

ℕE : Enum
ℕE = "zero" ∷ "suc" ∷ []

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

ℕR : Data
ℕR = ⊤ , ℕE
  , End tt
  , Rec tt (End tt)
  , tt

ℕD : Desc ⊤
ℕD = DataD ℕR

ℕ : ⊤ → Set
ℕ = μ ℕD

zero : ℕ tt
zero = init (zeroT , refl)

suc : ℕ tt → ℕ tt
suc n = init (sucT , n , refl)

VecR : (A : Set) → Data
VecR A = (ℕ tt) , VecE
  , End zero
  , Arg (ℕ tt) (λ n → Arg A λ _ → Rec n (End (suc n)))
  , tt

nilD : (A : Set) → Desc (ℕ tt)
nilD A = End zero

consD : (A : Set) → Desc (ℕ tt)
consD A = Arg (ℕ tt) (λ n → Arg A (λ _ → Rec n (End (suc n))))

VecD : (A : Set) → Desc (ℕ tt)
VecD A = DataD (VecR A)

Vec : (A : Set) → ℕ tt → Set
Vec A = μ (VecD A)

NilEl : (A : Set) (n : ℕ tt) → Set
NilEl A n = El (nilD A) (Vec A) n

ConsEl : (A : Set) → ℕ tt → Set
ConsEl A n = El (consD A) (Vec A) n

VecEl : (A : Set) → ℕ tt → Set
VecEl A n = El (VecD A) (Vec A) n

NilHyps : (A : Set) (P : (n : ℕ tt) → Vec A n → Set) (n : ℕ tt) (xs : NilEl A n) → Set
NilHyps A P n xs = Hyps (nilD A) (Vec A) P n xs

ConsHyps : (A : Set) (P : (n : ℕ tt) → Vec A n → Set) (n : ℕ tt) (xs : ConsEl A n) → Set
ConsHyps A P n xs = Hyps (consD A) (Vec A) P n xs

VecHyps : (A : Set) (P : (n : ℕ tt) → Vec A n → Set) (n : ℕ tt) (xs : VecEl A n) → Set
VecHyps A P n xs = Hyps (VecD A) (Vec A) P n xs

ConsUncurriedHyps : (A : Set)
  (P : (n : ℕ tt) → Vec A n → Set)
  (cn : UncurriedEl (consD A) (Vec A)) → Set
ConsUncurriedHyps A P cn = UncurriedHyps (consD A) (Vec A) P cn

nil : (A : Set) → Vec A zero
nil A = init (nilT , refl)

cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A n x xs = init (consT , n , x , xs , refl)

nil2 : (A : Set) → Vec A zero
nil2 A = inj (VecR A) nilT

cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
cons2 A = inj (VecR A) consT

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

add : ℕ tt → ℕ tt → ℕ tt
add = elim ℕR (λ u n → ℕ tt → ℕ tt)
  (λ n → n)
  (λ m ih n → suc (ih n))
  tt

mult : ℕ tt → ℕ tt → ℕ tt
mult = elim ℕR (λ u n → ℕ tt → ℕ tt)
  (λ n → zero)
  (λ m ih n → add n (ih n))
  tt

append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
append A = elim (VecR A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
  (λ n ys → ys)
  (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat A m = elim (VecR (Vec A m)) (λ n xss → Vec A (mult n m))
  (nil A)
  (λ n xs xss ih → append A m xs (mult n m) ih)

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


module PatternSynonymOverapplied2 where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

pattern suc' x = suc x

f : Nat -> Nat
f zero       = zero
f (suc' m n) = n


{-# OPTIONS --universe-polymorphism #-}
open import Common.Prelude
open import Common.Level
open import Common.Reflect

module UnquoteSetOmega where

`Level : Term
`Level = def (quote Level) []

``Level : Type
``Level = el (lit 0) `Level

-- while building the syntax of ∀ ℓ → Set ℓ (of type Setω) is harmless
`∀ℓ→Setℓ : Term
`∀ℓ→Setℓ = pi (arg (arginfo visible relevant) ``Level) (el (lit 0) (sort (set (var 0 []))))

-- unquoting it is harmfull
∀ℓ→Setℓ = unquote `∀ℓ→Setℓ


{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module Bottom where

open import Common.FOL.FOL-Eq

postulate bot : ⊥

postulate
  zero : D
  succ : D → D

postulate false : zero ≡ succ zero
{-# ATP prove false bot #-}

-- $ apia -isrc -inotes/papers/FoSSaCS-2012/  notes/papers/FoSSaCS-2012/Bottom.agda
-- Proving the conjecture in /tmp/Bottom/16-false.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture in /tmp/Bottom/16-false.tptp


-- Andreas, 2018-09-08, issue #3211
--
-- Bug with parametrized module and constructor rewriting.

{-# OPTIONS --rewriting #-}
-- {-# OPTIONS -v rewriting.match:90 -v rewriting:90 #-}
-- {-# OPTIONS -v tc.getConType:50 #-}

module _ (Base : Set) where

open import Agda.Builtin.Equality
{-# 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 Form : Set where
  Atom : (P : Base) → Form
  _⇒_ : (A B : Form) → Form

data Cxt : Set where
  ε : Cxt
  _∙_ : (Γ : Cxt) (A : Form) → Cxt

infixl 4 _∙_
infix 3 _≤_

data _≤_ : (Γ Δ : Cxt) → Set where
  id≤ : ∀{Γ} → Γ ≤ Γ
  weak : ∀{A Γ Δ} (τ : Γ ≤ Δ) → Γ ∙ A ≤ Δ
  lift : ∀{A Γ Δ} (τ : Γ ≤ Δ) → Γ ∙ A ≤ Δ ∙ A

postulate lift-id≤ : ∀{Γ A} → lift id≤ ≡ id≤ {Γ ∙ A}
{-# REWRITE lift-id≤ #-}

Mon : (P : Cxt → Set) → Set
Mon P = ∀{Γ Δ} (τ : Γ ≤ Δ) → P Δ → P Γ

infix 2 _⊢_

data _⊢_ (Γ : Cxt) : (A : Form) → Set where
  impI   : ∀{A B} (t : Γ ∙ A ⊢ B) → Γ ⊢ A ⇒ B

Tm = λ A Γ → Γ ⊢ A

monD : ∀{A} → Mon (Tm A)
-- monD : ∀{A Γ Δ} (τ : Γ ≤ Δ) → Tm A Δ → Tm A Γ  -- Works
-- monD : ∀{A Γ Δ} (τ : Γ ≤ Δ) → Δ ⊢ A → Γ ⊢ A    -- Works
monD τ (impI t)    = impI (monD (lift τ) t)

monD-id : ∀{Γ A} (t : Γ ⊢ A) → monD id≤ t ≡ t
monD-id (impI t) = cong impI (monD-id t)  -- REWRITE lift-id≤

-- -}


module Subst where

import Level

postulate Ty : Set

data Cxt : Set where
  ε   : Cxt
  _,_ : (Γ : Cxt) (A : Ty) → Cxt

_++_ : Cxt → Cxt → Cxt
Γ ++ ε       = Γ
Γ ++ (Δ , A) = (Γ ++ Δ) , A

data Tm : Cxt → Ty → Set where
  vz : ∀ {Γ A} → Tm (Γ , A) A
  other : ∀ {Γ A} → Tm Γ A

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

{-# BUILTIN EQUALITY _≡_ #-}
{-# BUILTIN REFL refl #-}

data Sub : Cxt → Cxt → Set where
  _∷_  : ∀ {Γ Δ A} → Tm Γ A → Sub Γ Δ → Sub Γ (Δ , A)
  lift : ∀ {Γ Δ} Ψ → Sub Γ Δ → Sub (Γ ++ Ψ) (Δ ++ Ψ)
  wk   : ∀ {Γ Δ} Ψ → Sub Γ Δ → Sub (Γ ++ Ψ) Δ
  id   : ∀ {Γ} → Sub Γ Γ
  ∅    : ∀ {Γ} → Sub Γ ε

assoc : ∀ {Γ Δ} Ψ → (Γ ++ (Δ ++ Ψ)) ≡ ((Γ ++ Δ) ++ Ψ)
assoc ε = refl
assoc {Γ}{Δ} (Ψ , A) rewrite assoc {Γ} {Δ} Ψ = refl

ε++ : ∀ Γ → (ε ++ Γ) ≡ Γ
ε++ ε = refl
ε++ (Γ , A) rewrite ε++ Γ = refl

postulate

  apply : ∀ {Γ Δ A} → Sub Γ Δ → Tm Δ A → Tm Γ A

sym : ∀ {A : Set}{x y : A} → x ≡ y → y ≡ x
sym refl = refl

cast : ∀ {Γ₁ Γ₂ Δ₁ Δ₂} → Γ₁ ≡ Γ₂ → Δ₁ ≡ Δ₂ → Sub Γ₁ Δ₁ → Sub Γ₂ Δ₂
cast refl refl ρ = ρ

inj : ∀ {Γ Δ A B} → (Γ , A) ≡ (Δ , B) → Γ ≡ Δ
inj refl = refl

injT : ∀ {Γ Δ A B} → (Γ , A) ≡ (Δ , B) → A ≡ B
injT refl = refl

drop : ∀ {Γ Δ ΔΨ} Ψ → Sub Γ ΔΨ → ΔΨ ≡ (Δ ++ Ψ) → Sub Γ Δ
drop Ψ id refl = wk Ψ id
drop Ψ (wk Δ ρ) refl = wk Δ (drop Ψ ρ refl)
drop Ψ (lift ε ρ) refl = drop Ψ ρ refl
drop ε ρ refl = ρ
drop (Ψ , A) (x ∷ ρ) refl = drop Ψ ρ refl
drop {Δ = Δ} (Ψ , A) (lift {Γ = Γ}{Δ = Σ} (Θ , A′) ρ) eq =
     wk (ε , A′) (drop Ψ (lift Θ ρ) (inj eq))
drop (Ψ , A) ∅ ()

wkS : ∀ {Γ Δ} Ψ → Sub Γ Δ → Sub (Γ ++ Ψ) Δ
wkS ε ρ = ρ
wkS Ψ (x ∷ ρ) = (apply (wk Ψ id) x) ∷ wkS Ψ ρ
wkS Ψ (lift Ψ₁ ρ) = wk Ψ (lift Ψ₁ ρ)
wkS Ψ (wk Ψ₁ ρ) = cast (assoc Ψ) refl (wkS (Ψ₁ ++ Ψ) ρ)
wkS Ψ id = wk Ψ id
wkS Ψ ∅ = ∅

liftS : ∀ {Γ Δ} Ψ → Sub Γ Δ → Sub (Γ ++ Ψ) (Δ ++ Ψ)
liftS Ψ (x ∷ ρ) = lift Ψ (x ∷ ρ)
liftS Ψ (lift Ψ₁ ρ) = cast (assoc Ψ) (assoc Ψ) (liftS (Ψ₁ ++ Ψ) ρ)
liftS Ψ (wk Ψ₁ ρ) = lift Ψ (wk Ψ₁ ρ)
liftS Ψ id = id
liftS Ψ ∅ = lift Ψ ∅

data _×_ A B : Set where
  _,_ : A → B → A × B

split : ∀ {Γ Δ ΔΨ} Ψ → Sub Γ ΔΨ → ΔΨ ≡ (Δ ++ Ψ) → Sub Γ Δ × Sub Γ Ψ
split {Γ} ε ρ refl = ρ , ∅
split (Ψ , A) (x ∷ ρ) refl with split Ψ ρ refl
... | σ , δ = σ , (x ∷ δ)
split Ψ (lift ε ρ) eq = split Ψ ρ eq
split (Ψ , A) (lift (Ψ₁ , A₁) ρ) eq with split Ψ (lift Ψ₁ ρ) (inj eq) | injT eq
split (Ψ , A) (lift (Ψ₁ , .A) ρ) eq | σ , δ | refl =
  wk (ε , A) σ , lift (ε , A) δ
split Ψ (wk Ψ₁ ρ) eq with split Ψ ρ eq
... | σ , δ = wk Ψ₁ σ , wk Ψ₁ δ
split {Δ = Δ} Ψ id refl = wk Ψ id , cast refl (ε++ Ψ) (lift {Γ = Δ} Ψ ∅)
split (Ψ , A) ∅ ()

_<>_ : ∀ {Γ Δ Ψ} → Sub Γ Ψ → Sub Γ Δ → Sub Γ (Δ ++ Ψ)
(x ∷ ρ) <> σ = x ∷ (ρ <> σ)
lift Ψ ρ <> σ = {!!}
wk Ψ₁ ρ <> σ = {!!}
-- _<>_ {Ψ = Ψ} id (_∷_ {Δ = Δ}{A = A} x σ) = cast refl (assoc {_}{ε , A} Ψ)
--   (_<>_ {Ψ = (ε , A) ++ Ψ} {!!} σ)
id <> lift Ψ σ = {!!}
id <> wk Ψ σ = {!!}
id <> id = {!!}
_<>_ {Ψ = Ψ} id ∅ = cast (ε++ Ψ) refl id
_<>_ {Ψ = ε} id σ = {!!}
_<>_ {Ψ = Ψ , A} id σ = vz ∷ (_<>_ {Ψ = Ψ} (wk (ε , A) id) σ)
∅ <> σ = σ

comp : ∀ {Γ Δ Δ′ Ψ} → Sub Γ Δ → Sub Δ′ Ψ → Δ ≡ Δ′ → Sub Γ Ψ
comp ρ id refl = ρ
comp ρ (wk Δ σ) refl = comp (drop Δ ρ refl) σ refl
comp ρ (x ∷ σ) refl = apply ρ x ∷ comp ρ σ refl
comp ρ (lift ε σ) refl = comp ρ σ refl
comp ρ (lift Ψ σ) refl with split Ψ ρ refl
... | ρ₁ , ρ₂ = ρ₂ <> comp ρ₁ σ refl
comp {Γ} ∅ σ refl = cast (ε++ Γ) refl (wk Γ σ)
-- comp (u ∷ ρ) (lift (Ψ , A) σ) eq
--   with injT eq
-- ... | refl = u ∷ comp ρ (lift Ψ σ) (inj eq)
-- comp ρ (lift (Ψ , A) σ) eq =
--   apply (cast refl eq ρ) vz ∷
--   comp ρ (wk (ε , A) (lift Ψ σ)) eq
comp ρ ∅ refl = ∅

_∘_ : ∀ {Γ Δ Ψ} → Sub Γ Δ → Sub Δ Ψ → Sub Γ Ψ
ρ ∘ σ = comp ρ σ refl


{-# OPTIONS --guardedness #-}

module Cubical.Codata.Conat where

open import Cubical.Codata.Conat.Base public

open import Cubical.Codata.Conat.Properties public


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Universe where

open import Cubical.Data.Universe.Base public

open import Cubical.Data.Universe.Properties public


-- Andreas, 2016-07-29, issue #1720 reported by Mietek Bak

{-# OPTIONS --double-check #-}

postulate
  A  : Set
  B  : A → Set
  a0 : A
  b0 : B a0

record R (a1 : A) (b1 : B a1) : Set where

  field fa : A

  a : A
  a = {!a1!}

  field fb : B fa

  b : B {!!}
  b = {!b1!}

  field f : A

-- Problem:
-- Interaction points are doubled.